diff options
112 files changed, 20639 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..099cef7 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +mutt/mailboxes.rc.oi diff --git a/awesomerc/rc-choose.lua b/awesomerc/rc-choose.lua new file mode 100644 index 0000000..c30f52c --- /dev/null +++ b/awesomerc/rc-choose.lua @@ -0,0 +1,57 @@ +-- Choose which RC to run based on what Awesome is running +-- and also whether or not that RC crashed last time + +local rcgroup = "unknown" + +if awesome.release == "Smack" then + rcgroup = "3.4.9" +else + if string.match(awesome.version, "%-g[0-9a-f]+$") then + rcgroup = "git" + end +end + +-- For now, if we detect we're running 3.4.9 release then +-- we force ourselves to choose to run the /etc/ RC file +if rcgroup == "3.4.9" then + return assert(loadfile("/etc/xdg/awesome/rc.lua"))() +end + +-- If we're running the GIT version then we have to +-- consider where to find the default RC +local defaultrc = "/usr/local/etc/xdg/awesome/rc.lua" +local tracebackfilename = os.getenv("HOME") .. "/.config/awesome/rc-git-traceback.txt" + +-- If we find that we have a traceback then we run +-- the default RC and then ensure we spawn an editor with it in. +local tracebackfh = io.open(tracebackfilename, "r") +if tracebackfh then + tracebackfh:close() + assert(loadfile(defaultrc))() + require("awful").util.spawn("gnome-open " .. tracebackfilename, false) + return +end + +-- Otherwise we're going to try and run the main RC and failing that +-- we're going to store the traceback and restart awesome. + +local function try_run_rc() + local homec = os.getenv("HOME") .. "/.resources/awesomerc/rc-" .. rcgroup + package.path = package.path .. ";" .. homec .. "/?.lua;" .. homec .. "/?/init.lua" + require("rc-" .. rcgroup) + -- TODO: Perform various sanity checks such as there being at least one tag + -- on each screen. For now, this'll do. +end + +local ok, traceback = xpcall(try_run_rc, debug.traceback) + +if not ok then + tracebackfh = io.open(tracebackfilename, "w") + tracebackfh:write(traceback) + tracebackfh:close() + awesome.restart() +end + +-- Either we were OK, or bad crud happened, either way, let awesome try +-- and fall back however it might. + diff --git a/awesomerc/rc-git/cal.lua b/awesomerc/rc-git/cal.lua new file mode 100644 index 0000000..50c533d --- /dev/null +++ b/awesomerc/rc-git/cal.lua @@ -0,0 +1,121 @@ +-- original code made by Bzed and published on http://awesome.naquadah.org/wiki/Calendar_widget +-- modified by Marc Dequènes (Duck) <Duck@DuckCorp.org> (2009-12-29), under the same licence, +-- and with the following changes: +-- + transformed to module +-- + the current day formating is customizable +-- modified by Jörg Thalheim (Mic92) <jthalheim@gmail.com> (2011), under the same licence, +-- and with the following changes: +-- + use tooltip instead of naughty.notify +-- + rename it to cal +-- +-- # How to Install # +-- 1. Download the code and move it into your config directory +-- wget --no-check-certificate https://github.com/Mic92/awesome-dotfiles/raw/master/cal.lua -O $XDG_CONFIG_HOME/awesome/cal.lua +-- 2. require it in your rc.lua +-- require("cal") +-- 3. attach the calendar to a widget of your choice (ex mytextclock) +-- cal.register(mytextclock) +-- If you don't like the default current day formating you can change it as following +-- cal.register(mytextclock, "<b>%s</b>") -- now the current day is bold instead of underlined +-- +-- # How to Use # +-- Just hover with your mouse over the widget, you register and the calendar popup. +-- On clicking or by using the mouse wheel the displayed month changes. +-- Pressing Shift + Mouse click change the year. + +local string = {format = string.format} +local os = {date = os.date, time = os.time} +local awful = require("awful") + +module("cal") + +local tooltip +local state = {} +local current_day_format = "<u>%s</u>" + +function displayMonth(month,year,weekStart) + local t,wkSt=os.time{year=year, month=month+1, day=0},weekStart or 1 + local d=os.date("*t",t) + local mthDays,stDay=d.day,(d.wday-d.day-wkSt+1)%7 + + local lines = " " + + for x=0,6 do + lines = lines .. os.date("%a ",os.time{year=2006,month=1,day=x+wkSt}) + end + + lines = lines .. "\n" .. os.date(" %V",os.time{year=year,month=month,day=1}) + + local writeLine = 1 + while writeLine < (stDay + 1) do + lines = lines .. " " + writeLine = writeLine + 1 + end + + for d=1,mthDays do + local x = d + local t = os.time{year=year,month=month,day=d} + if writeLine == 8 then + writeLine = 1 + lines = lines .. "\n" .. os.date(" %V",t) + end + if os.date("%Y-%m-%d") == os.date("%Y-%m-%d", t) then + x = string.format(current_day_format, d) + end + if d < 10 then + x = " " .. x + end + lines = lines .. " " .. x + writeLine = writeLine + 1 + end + local header = os.date("%B %Y\n",os.time{year=year,month=month,day=1}) + + return header .. "\n" .. lines +end + +function register(mywidget, custom_current_day_format) + if custom_current_day_format then current_day_format = custom_current_day_format end + + if not tooltip then + tooltip = awful.tooltip({}) + end + tooltip:add_to_object(mywidget) + + mywidget:add_signal("mouse::enter", function() + local month, year = os.date('%m'), os.date('%Y') + state = {month, year} + tooltip:set_text(string.format('<span font_desc="monospace">%s</span>', displayMonth(month, year, 2))) + end) + + mywidget:buttons(awful.util.table.join( + awful.button({ }, 1, function() + switchMonth(-1) + end), + awful.button({ }, 3, function() + switchMonth(1) + end), + awful.button({ }, 4, function() + switchMonth(-1) + end), + awful.button({ }, 5, function() + switchMonth(1) + end), + awful.button({ 'Shift' }, 1, function() + switchMonth(-12) + end), + awful.button({ 'Shift' }, 3, function() + switchMonth(12) + end), + awful.button({ 'Shift' }, 4, function() + switchMonth(-12) + end), + awful.button({ 'Shift' }, 5, function() + switchMonth(12) + end))) +end + +function switchMonth(delta) + state[1] = state[1] + (delta or 1) + local text = string.format('<span font_desc="monospace">%s</span>', displayMonth(state[1], state[2], 2)) + tooltip:set_text(text) +end diff --git a/awesomerc/rc-git/danburn/awesome-icon.png b/awesomerc/rc-git/danburn/awesome-icon.png Binary files differnew file mode 100644 index 0000000..70978d3 --- /dev/null +++ b/awesomerc/rc-git/danburn/awesome-icon.png diff --git a/awesomerc/rc-git/danburn/layouts/dwindle.png b/awesomerc/rc-git/danburn/layouts/dwindle.png Binary files differnew file mode 100644 index 0000000..1aa4bf2 --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/dwindle.png diff --git a/awesomerc/rc-git/danburn/layouts/fairh.png b/awesomerc/rc-git/danburn/layouts/fairh.png Binary files differnew file mode 100644 index 0000000..e176bb3 --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/fairh.png diff --git a/awesomerc/rc-git/danburn/layouts/fairv.png b/awesomerc/rc-git/danburn/layouts/fairv.png Binary files differnew file mode 100644 index 0000000..7c0a92c --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/fairv.png diff --git a/awesomerc/rc-git/danburn/layouts/floating.png b/awesomerc/rc-git/danburn/layouts/floating.png Binary files differnew file mode 100644 index 0000000..a399092 --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/floating.png diff --git a/awesomerc/rc-git/danburn/layouts/fullscreen.png b/awesomerc/rc-git/danburn/layouts/fullscreen.png Binary files differnew file mode 100644 index 0000000..a0c795c --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/fullscreen.png diff --git a/awesomerc/rc-git/danburn/layouts/magnifier.png b/awesomerc/rc-git/danburn/layouts/magnifier.png Binary files differnew file mode 100644 index 0000000..bca6db9 --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/magnifier.png diff --git a/awesomerc/rc-git/danburn/layouts/max.png b/awesomerc/rc-git/danburn/layouts/max.png Binary files differnew file mode 100644 index 0000000..96a237a --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/max.png diff --git a/awesomerc/rc-git/danburn/layouts/spiral.png b/awesomerc/rc-git/danburn/layouts/spiral.png Binary files differnew file mode 100644 index 0000000..8f5aeed --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/spiral.png diff --git a/awesomerc/rc-git/danburn/layouts/tile.png b/awesomerc/rc-git/danburn/layouts/tile.png Binary files differnew file mode 100644 index 0000000..3fcc904 --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/tile.png diff --git a/awesomerc/rc-git/danburn/layouts/tilebottom.png b/awesomerc/rc-git/danburn/layouts/tilebottom.png Binary files differnew file mode 100644 index 0000000..dfe7832 --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/tilebottom.png diff --git a/awesomerc/rc-git/danburn/layouts/tileleft.png b/awesomerc/rc-git/danburn/layouts/tileleft.png Binary files differnew file mode 100644 index 0000000..c5decfd --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/tileleft.png diff --git a/awesomerc/rc-git/danburn/layouts/tiletop.png b/awesomerc/rc-git/danburn/layouts/tiletop.png Binary files differnew file mode 100644 index 0000000..b251661 --- /dev/null +++ b/awesomerc/rc-git/danburn/layouts/tiletop.png diff --git a/awesomerc/rc-git/danburn/taglist/squarefz.png b/awesomerc/rc-git/danburn/taglist/squarefz.png Binary files differnew file mode 100644 index 0000000..0927720 --- /dev/null +++ b/awesomerc/rc-git/danburn/taglist/squarefz.png diff --git a/awesomerc/rc-git/danburn/taglist/squarez.png b/awesomerc/rc-git/danburn/taglist/squarez.png Binary files differnew file mode 100644 index 0000000..9b41c26 --- /dev/null +++ b/awesomerc/rc-git/danburn/taglist/squarez.png diff --git a/awesomerc/rc-git/danburn/theme.lua b/awesomerc/rc-git/danburn/theme.lua new file mode 100644 index 0000000..2db3717 --- /dev/null +++ b/awesomerc/rc-git/danburn/theme.lua @@ -0,0 +1,127 @@ +------------------------------- +-- "Danburn" modification of -- +-- "Zenburn" awesome theme -- +-- By Adrian C. (anrxc) -- +------------------------------- + +-- Alternative icon sets and widget icons: +-- * http://awesome.naquadah.org/wiki/Nice_Icons + +-- {{{ Main +theme = {} +theme.wallpaper_cmd = { "awsetbg " .. os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/zenburn-background.png" } +-- }}} + +-- {{{ Styles +theme.font = "Inconsolata 8.5" + +-- {{{ Colors +theme.fg_normal = "#DCDCCC" +theme.fg_focus = "#F0DFAF" +theme.fg_urgent = "#CC9393" +theme.bg_normal = "#3F3F3F" +theme.bg_focus = "#1E2320" +theme.bg_urgent = "#3F3F3F" +theme.bg_systray = theme.bg_normal +-- }}} + +-- {{{ Borders +theme.border_width = 1 +theme.border_normal = "#3F3F3F" +theme.border_focus = "#6F6F6F" +theme.border_marked = "#CC9393" +-- }}} + +-- {{{ Titlebars +theme.titlebar_bg_focus = "#3F3F3F" +theme.titlebar_bg_normal = "#3F3F3F" +-- }}} + +-- There are other variable sets +-- overriding the default one when +-- defined, the sets are: +-- [taglist|tasklist]_[bg|fg]_[focus|urgent] +-- titlebar_[normal|focus] +-- tooltip_[font|opacity|fg_color|bg_color|border_width|border_color] +-- Example: +--theme.taglist_bg_focus = "#CC9393" +-- }}} + +-- {{{ Widgets +-- You can add as many variables as +-- you wish and access them by using +-- beautiful.variable in your rc.lua +--theme.fg_widget = "#AECF96" +--theme.fg_center_widget = "#88A175" +--theme.fg_end_widget = "#FF5656" +--theme.bg_widget = "#494B4F" +--theme.border_widget = "#3F3F3F" +-- }}} + +-- {{{ Mouse finder +theme.mouse_finder_color = "#CC9393" +-- mouse_finder_[timeout|animate_timeout|radius|factor] +-- }}} + +-- {{{ Menu +-- Variables set for theming the menu: +-- menu_[bg|fg]_[normal|focus] +-- menu_[border_color|border_width] +theme.menu_height = 15 +theme.menu_width = 100 +-- }}} + +-- {{{ Icons +-- {{{ Taglist +theme.taglist_squares_sel = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/taglist/squarefz.png" +theme.taglist_squares_unsel = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/taglist/squarez.png" +--theme.taglist_squares_resize = "false" +-- }}} + +-- {{{ Misc +theme.awesome_icon = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/awesome-icon.png" +theme.menu_submenu_icon = "/usr/local/share/awesome/themes/default/submenu.png" +-- }}} + +-- {{{ Layout +theme.layout_tile = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/tile.png" +theme.layout_tileleft = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/tileleft.png" +theme.layout_tilebottom = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/tilebottom.png" +theme.layout_tiletop = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/tiletop.png" +theme.layout_fairv = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/fairv.png" +theme.layout_fairh = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/fairh.png" +theme.layout_spiral = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/spiral.png" +theme.layout_dwindle = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/dwindle.png" +theme.layout_max = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/max.png" +theme.layout_fullscreen = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/fullscreen.png" +theme.layout_magnifier = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/magnifier.png" +theme.layout_floating = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/layouts/floating.png" +-- }}} + +-- {{{ Titlebar +theme.titlebar_close_button_focus = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/close_focus.png" +theme.titlebar_close_button_normal = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/close_normal.png" + +theme.titlebar_ontop_button_focus_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/ontop_focus_active.png" +theme.titlebar_ontop_button_normal_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/ontop_normal_active.png" +theme.titlebar_ontop_button_focus_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.png" +theme.titlebar_ontop_button_normal_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.png" + +theme.titlebar_sticky_button_focus_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/sticky_focus_active.png" +theme.titlebar_sticky_button_normal_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/sticky_normal_active.png" +theme.titlebar_sticky_button_focus_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.png" +theme.titlebar_sticky_button_normal_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.png" + +theme.titlebar_floating_button_focus_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/floating_focus_active.png" +theme.titlebar_floating_button_normal_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/floating_normal_active.png" +theme.titlebar_floating_button_focus_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.png" +theme.titlebar_floating_button_normal_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.png" + +theme.titlebar_maximized_button_focus_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/maximized_focus_active.png" +theme.titlebar_maximized_button_normal_active = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/maximized_normal_active.png" +theme.titlebar_maximized_button_focus_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.png" +theme.titlebar_maximized_button_normal_inactive = os.getenv("HOME") .. "/.resources/awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.png" +-- }}} +-- }}} + +return theme diff --git a/awesomerc/rc-git/danburn/titlebar/close_focus.png b/awesomerc/rc-git/danburn/titlebar/close_focus.png Binary files differnew file mode 100644 index 0000000..02565b9 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/close_focus.png diff --git a/awesomerc/rc-git/danburn/titlebar/close_normal.png b/awesomerc/rc-git/danburn/titlebar/close_normal.png Binary files differnew file mode 100644 index 0000000..982da6c --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/close_normal.png diff --git a/awesomerc/rc-git/danburn/titlebar/floating_focus_active.png b/awesomerc/rc-git/danburn/titlebar/floating_focus_active.png Binary files differnew file mode 100644 index 0000000..63d900b --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/floating_focus_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.png Binary files differnew file mode 100644 index 0000000..461ab52 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.png diff --git a/awesomerc/rc-git/danburn/titlebar/floating_normal_active.png b/awesomerc/rc-git/danburn/titlebar/floating_normal_active.png Binary files differnew file mode 100644 index 0000000..9e6a239 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/floating_normal_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.png Binary files differnew file mode 100644 index 0000000..df28637 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.png diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_focus_active.png b/awesomerc/rc-git/danburn/titlebar/maximized_focus_active.png Binary files differnew file mode 100644 index 0000000..834f106 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/maximized_focus_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.png Binary files differnew file mode 100644 index 0000000..55ff310 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.png diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_normal_active.png b/awesomerc/rc-git/danburn/titlebar/maximized_normal_active.png Binary files differnew file mode 100644 index 0000000..98f5522 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/maximized_normal_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.png Binary files differnew file mode 100644 index 0000000..a2d0ff1 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.png diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_focus_active.png b/awesomerc/rc-git/danburn/titlebar/ontop_focus_active.png Binary files differnew file mode 100644 index 0000000..776d586 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/ontop_focus_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.png Binary files differnew file mode 100644 index 0000000..f677f15 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.png diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_normal_active.png b/awesomerc/rc-git/danburn/titlebar/ontop_normal_active.png Binary files differnew file mode 100644 index 0000000..e70de36 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/ontop_normal_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.png Binary files differnew file mode 100644 index 0000000..754b9bb --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.png diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_focus_active.png b/awesomerc/rc-git/danburn/titlebar/sticky_focus_active.png Binary files differnew file mode 100644 index 0000000..1726f90 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/sticky_focus_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.png Binary files differnew file mode 100644 index 0000000..efc020f --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.png diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_normal_active.png b/awesomerc/rc-git/danburn/titlebar/sticky_normal_active.png Binary files differnew file mode 100644 index 0000000..c87f21a --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/sticky_normal_active.png diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.png Binary files differnew file mode 100644 index 0000000..0b24f37 --- /dev/null +++ b/awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.png diff --git a/awesomerc/rc-git/danburn/zenburn-background.png b/awesomerc/rc-git/danburn/zenburn-background.png Binary files differnew file mode 100644 index 0000000..1eb9437 --- /dev/null +++ b/awesomerc/rc-git/danburn/zenburn-background.png diff --git a/awesomerc/rc-git/djas.lua b/awesomerc/rc-git/djas.lua new file mode 100644 index 0000000..863b358 --- /dev/null +++ b/awesomerc/rc-git/djas.lua @@ -0,0 +1,47 @@ +module(..., package.seeall) + +function sprint(...) + local t = {...} + local n = select("#",...) + local out = {} + out[#out + 1] = (tostring(t[1])) + for i = 2,n do + out[#out + 1] = (tostring(t[i])) + end + return table.concat(out, "\t") +end + +function print(...) + io.stderr:write(sprint(...)) + io.stderr:write("\n") +end + +function warpdir(c,d) + local tt = c:tags()[1] + local scr = screen[c.screen] + local alltags = scr:tags() + local t + for i = 1, #alltags do + if alltags[i] == tt then + t = i + end + end + t = t + d + if t == 0 then t = #alltags end + if t > #alltags then t = 1 end + c:tags { alltags[t] } + awful.tag.viewonly(alltags[t]) +end + +function warpprev(c) + warpdir(c, -1) +end + +function warpnext(c) + warpdir(c, 1) +end + +function nprint(...) + local s = sprint(...) + naughty.notify { text = "NPRINT: " .. s } +end
\ No newline at end of file diff --git a/awesomerc/rc-git/init-pre-shifty.lua b/awesomerc/rc-git/init-pre-shifty.lua new file mode 100644 index 0000000..a561736 --- /dev/null +++ b/awesomerc/rc-git/init-pre-shifty.lua @@ -0,0 +1,391 @@ +-- Standard awesome library +require("awful") +require("awful.autofocus") +require("awful.rules") +-- Widget and layout library +require("wibox") +-- Theme handling library +require("beautiful") +-- Notification library +require("naughty") + +-- Handy locals +local tjoin = awful.util.table.join + +-- {{{ Variable definitions +-- Themes define colours, icons, and wallpapers +beautiful.init("/usr/local/share/awesome/themes/default/theme.lua") + +-- This is used later as the default terminal and editor to run. +terminal = "gnome-terminal" +editor = os.getenv("EDITOR") or "nano" +editor_cmd = terminal .. " -e " .. editor + +-- Default modkey. +-- Usually, Mod4 is the key with a logo between Control and Alt. +-- If you do not like this or do not have such a key, +-- I suggest you to remap Mod4 to another key using xmodmap or other tools. +-- However, you can use another modifier like Mod1, but it may interact with others. +modkey = "Mod4" + +-- Table of layouts to cover with awful.layout.inc, order matters. +layouts = { + awful.layout.suit.floating, + awful.layout.suit.tile, + awful.layout.suit.fair, +-- awful.layout.suit.fair.horizontal, +-- awful.layout.suit.max, +-- awful.layout.suit.max.fullscreen, +} +-- }}} + +-- {{{ Tags +-- Define a tag table which hold all screen tags. +tags = {} +for s = 1, screen.count() do + -- Each screen has its own tag table. + tags[s] = awful.tag({ 1, 2, 3, 4, 5, 6, 7, 8, 9 }, s, layouts[1]) +end +-- }}} + +-- {{{ Menu +-- Create a laucher widget and a main menu + +function sessionmethod(d) + awful.util.spawn("gnome-session-save " .. d, false) +end + +myawesomemenu = { + { "manual", terminal .. " -e man awesome" }, + { "edit config", editor_cmd .. " " .. awful.util.getdir("config") .. "/rc-new.lua" }, + { "restart", awesome.restart }, + { "quit", awesome.quit } +} + +mymainmenu = + awful.menu({ items = + { { "awesome", myawesomemenu, beautiful.awesome_icon }, + { "open terminal", terminal }, + { "log out", function () sessionmethod "--logout-dialog" end }, + { "shut down", function () sessionmethod "--shutdown-dialog" end }, + } + }) + +mylauncher = awful.widget.launcher({ image = beautiful.awesome_icon, + menu = mymainmenu }) +-- }}} + +-- {{{ Wibox +-- Create a textclock widget +mytextclock = awful.widget.textclock() + +-- Create a wibox for each screen and add it +mywibox = {} +mypromptbox = {} +mylayoutbox = {} +mytaglist = {} +mytaglist.buttons = tjoin( + awful.button({ }, 1, awful.tag.viewonly), + awful.button({ modkey }, 1, awful.client.movetotag), + awful.button({ }, 3, awful.tag.viewtoggle), + awful.button({ modkey }, 3, awful.client.toggletag), + awful.button({ }, 4, awful.tag.viewnext), + awful.button({ }, 5, awful.tag.viewprev) + ) +mytasklist = {} +mytasklist.buttons = + tjoin( + awful.button({ }, 1, function (c) + if c == client.focus then + c.minimized = true + else + if not c:isvisible() then + awful.tag.viewonly(c:tags()[1]) + end + -- This will also un-minimize + -- the client, if needed + client.focus = c + c:raise() + end + end), + awful.button({ }, 3, function () + if instance then + instance:hide() + instance = nil + else + instance = awful.menu.clients({ width=250 }) + end + end), + awful.button({ }, 4, function () + awful.client.focus.byidx(1) + if client.focus then client.focus:raise() end + end), + awful.button({ }, 5, function () + awful.client.focus.byidx(-1) + if client.focus then client.focus:raise() end + end)) + +for s = 1, screen.count() do + -- Create a promptbox for each screen + mypromptbox[s] = awful.widget.prompt() + -- Create an imagebox widget which will contains an icon indicating which layout we're using. + -- We need one layoutbox per screen. + mylayoutbox[s] = awful.widget.layoutbox(s) + local function layout_button(n, m) + return awful.button({}, n, function () awful.layout.inc(layouts, m) end) + end + mylayoutbox[s]:buttons(tjoin( + layout_button(1, 1), + layout_button(3, -1), + layout_button(4, 1), + layout_button(4, -1))) + -- Create a taglist widget + mytaglist[s] = + awful.widget.taglist(s, awful.widget.taglist.filter.all, mytaglist.buttons) + + -- Create a tasklist widget + mytasklist[s] = + awful.widget.tasklist(s, awful.widget.tasklist.filter.currenttags, mytasklist.buttons) + + -- Create the wibox + mywibox[s] = awful.wibox({ position = "top", screen = s }) + + -- Widgets that are aligned to the left + local left_layout = wibox.layout.fixed.horizontal() + left_layout:add(mylauncher) + left_layout:add(mytaglist[s]) + left_layout:add(mypromptbox[s]) + + -- Widgets that are aligned to the right + local right_layout = wibox.layout.fixed.horizontal() + if s == 1 then right_layout:add(wibox.widget.systray()) end + right_layout:add(mytextclock) + right_layout:add(mylayoutbox[s]) + + -- Now bring it all together (with the tasklist in the middle) + local layout = wibox.layout.align.horizontal() + layout:set_left(left_layout) + layout:set_middle(mytasklist[s]) + layout:set_right(right_layout) + + mywibox[s]:set_widget(layout) +end +-- }}} + +-- {{{ Mouse bindings +root.buttons(tjoin( + awful.button({ }, 3, function () mymainmenu:toggle() end), + awful.button({ }, 4, awful.tag.viewnext), + awful.button({ }, 5, awful.tag.viewprev) + )) +-- }}} + +-- {{{ Key bindings +globalkeys = + tjoin( + awful.key({ modkey, }, "Left", + awful.tag.viewprev ), + awful.key({ modkey, }, "Right", + awful.tag.viewnext ), + awful.key({ modkey, }, "Escape", + awful.tag.history.restore), + + awful.key({ modkey, }, "j", + function () + awful.client.focus.byidx( 1) + if client.focus then client.focus:raise() end + end), + awful.key({ modkey, }, "k", + function () + awful.client.focus.byidx(-1) + if client.focus then client.focus:raise() end + end), + awful.key({ modkey, }, "w", + function () mymainmenu:show({keygrabber=true}) end), + + -- Layout manipulation + awful.key({ modkey, "Shift" }, "j", + function () awful.client.swap.byidx( 1) end), + awful.key({ modkey, "Shift" }, "k", + function () awful.client.swap.byidx( -1) end), + awful.key({ modkey, "Control" }, "j", + function () awful.screen.focus_relative( 1) end), + awful.key({ modkey, "Control" }, "k", + function () awful.screen.focus_relative(-1) end), + awful.key({ modkey, }, "u", + awful.client.urgent.jumpto), + awful.key({ modkey, }, "Tab", + function () + awful.client.focus.history.previous() + if client.focus then + client.focus:raise() + end + end), + + -- Standard program + awful.key({ modkey, }, "Return", + function () awful.util.spawn(terminal) end), + awful.key({ modkey, "Control" }, "r", + awesome.restart), + awful.key({ modkey, "Shift" }, "q", + awesome.quit), + + awful.key({ modkey, }, "l", + function () awful.tag.incmwfact( 0.05) end), + awful.key({ modkey, }, "h", + function () awful.tag.incmwfact(-0.05) end), + awful.key({ modkey, "Shift" }, "h", + function () awful.tag.incnmaster( 1) end), + awful.key({ modkey, "Shift" }, "l", + function () awful.tag.incnmaster(-1) end), + awful.key({ modkey, "Control" }, "h", + function () awful.tag.incncol( 1) end), + awful.key({ modkey, "Control" }, "l", + function () awful.tag.incncol(-1) end), + awful.key({ modkey, }, "space", + function () awful.layout.inc(layouts, 1) end), + awful.key({ modkey, "Shift" }, "space", + function () awful.layout.inc(layouts, -1) end), + + awful.key({ modkey, "Control" }, "n", + awful.client.restore), + + -- Prompt + awful.key({ modkey }, "r", + function () mypromptbox[mouse.screen]:run() end), + + awful.key({ modkey }, "x", + function () + awful.prompt.run({ prompt = "Run Lua code: " }, + mypromptbox[mouse.screen].widget, + awful.util.eval, nil, + awful.util.getdir("cache") .. "/history_eval") + end) + ) + +clientkeys = + tjoin( + awful.key({ modkey, }, "f", + function (c) c.fullscreen = not c.fullscreen end), + awful.key({ modkey, "Shift" }, "c", + function (c) c:kill() end), + awful.key({ modkey, "Control" }, "space", + awful.client.floating.toggle ), + awful.key({ modkey, "Control" }, "Return", + function (c) c:swap(awful.client.getmaster()) end), + awful.key({ modkey, }, "o", + awful.client.movetoscreen ), + awful.key({ modkey, }, "t", + function (c) c.ontop = not c.ontop end), + awful.key({ modkey, }, "n", + function (c) + -- The client currently has the input focus, so it cannot be + -- minimized, since minimized clients can't have the focus. + c.minimized = true + end), + awful.key({ modkey, }, "m", + function (c) + c.maximized_horizontal = not c.maximized_horizontal + c.maximized_vertical = not c.maximized_vertical + end) + ) + +-- Compute the maximum number of digit we need, limited to 9 +keynumber = 0 +for s = 1, screen.count() do + keynumber = math.min(9, math.max(#tags[s], keynumber)); +end + +-- Bind all key numbers to tags. +-- Be careful: we use keycodes to make it works on any keyboard layout. +-- This should map on the top row of your keyboard, usually 1 to 9. +for i = 1, keynumber do + globalkeys = tjoin(globalkeys, + awful.key({ modkey }, "#" .. i + 9, + function () + local screen = mouse.screen + if tags[screen][i] then + awful.tag.viewonly(tags[screen][i]) + end + end), + awful.key({ modkey, "Control" }, "#" .. i + 9, + function () + local screen = mouse.screen + if tags[screen][i] then + awful.tag.viewtoggle(tags[screen][i]) + end + end), + awful.key({ modkey, "Shift" }, "#" .. i + 9, + function () + if client.focus and tags[client.focus.screen][i] then + awful.client.movetotag(tags[client.focus.screen][i]) + end + end), + awful.key({ modkey, "Control", "Shift" }, "#" .. i + 9, + function () + if client.focus and tags[client.focus.screen][i] then + awful.client.toggletag(tags[client.focus.screen][i]) + end + end)) +end + +clientbuttons = tjoin( + awful.button({ }, 1, function (c) client.focus = c; c:raise() end), + awful.button({ modkey }, 1, awful.mouse.client.move), + awful.button({ modkey }, 3, awful.mouse.client.resize)) + +-- Set keys +root.keys(globalkeys) +-- }}} + +-- {{{ Rules +awful.rules.rules = { + -- All clients will match this rule. + { rule = { }, + properties = { border_width = beautiful.border_width, + border_color = beautiful.border_normal, + focus = true, + keys = clientkeys, + buttons = clientbuttons } }, + { rule = { class = "MPlayer" }, + properties = { floating = true } }, + { rule = { class = "pinentry" }, + properties = { floating = true } }, + { rule = { class = "gimp" }, + properties = { floating = true } }, + -- Set Firefox to always map on tags number 2 of screen 1. + -- { rule = { class = "Firefox" }, + -- properties = { tag = tags[1][2] } }, +} +-- }}} + +-- {{{ Signals +-- Signal function to execute when a new client appears. +do + function ___(c, startup) + -- Enable sloppy focus + c:connect_signal("mouse::enter", + function(c) + if awful.layout.get(c.screen) ~= awful.layout.suit.magnifier + and awful.client.focus.filter(c) then + client.focus = c + end + end) + + if not startup then + -- Set the windows at the slave, + -- i.e. put it at the end of others instead of setting it master. + -- awful.client.setslave(c) + + -- Put windows in a smart way, only if they does not set an initial position. + if not c.size_hints.user_position and not c.size_hints.program_position then + awful.placement.no_overlap(c) + awful.placement.no_offscreen(c) + end + end + end +client.connect_signal("manage", ___) +end +client.connect_signal("focus", function(c) c.border_color = beautiful.border_focus end) +client.connect_signal("unfocus", function(c) c.border_color = beautiful.border_normal end) +-- }}} diff --git a/awesomerc/rc-git/init.lua b/awesomerc/rc-git/init.lua new file mode 100644 index 0000000..0483e77 --- /dev/null +++ b/awesomerc/rc-git/init.lua @@ -0,0 +1,242 @@ +-- Standard awesome library +require("awful") +require("awful.autofocus") +require("awful.rules") +require "awful.layout" +require "awful.layout.suit" +-- Widget and layout library +require("wibox") +-- Theme handling library +require("beautiful") +-- Notification library +require("naughty") +-- Bring in 'shifty' (the nifty dynamic tags stuffs) +require "shifty" +-- Bring in my shifty configuration +require "shiftyconfig" +-- Bring in my handy utils +require 'djas' +-- My key setup +require 'keysetup' +-- Try bringing in the Debian menu config +require 'debian.menu' +-- Neat calendar widget +require 'cal' +-- Handy dandy state restoration booja +require 'reloader' +-- Pull the dbus augmentation for naughty in, so introspection doesn't fail +require 'naughtyaugment' + +-- Handy locals +local tjoin = awful.util.table.join + +-- {{{ Variable definitions +-- Themes define colours, icons, and wallpapers +--beautiful.init("/usr/local/share/awesome/themes/default/theme.lua") +beautiful.init(os.getenv("HOME").."/.resources/awesomerc/rc-git/danburn/theme.lua") + +-- This is used later as the default terminal and editor to run. +terminal = "gnome-terminal" +editor = os.getenv("EDITOR") or "nano" +editor_cmd = terminal .. " -e " .. editor + +-- Default modkey. +-- Usually, Mod4 is the key with a logo between Control and Alt. +-- If you do not like this or do not have such a key, +-- I suggest you to remap Mod4 to another key using xmodmap or other tools. +-- However, you can use another modifier like Mod1, but it may interact with others. +modkey = "Mod4" + +-- Table of layouts to cover with awful.layout.inc, order matters. +layouts = { + awful.layout.suit.floating, +-- awful.layout.suit.tile, + awful.layout.suit.fair, +} +-- }}} + + +-- {{{ Menu +-- Create a laucher widget and a main menu + +function sessionmethod(d) + awful.util.spawn("gnome-session-quit " .. d, false) +end + +myawesomemenu = { +-- { "manual", terminal .. " -e man awesome" }, +-- { "edit config", editor_cmd .. " " .. awful.util.getdir("config") .. "/rc-new.lua" }, + { "restart", awesome.restart }, + { "quit", awesome.quit } +} + +mymainmenu = + awful.menu({ items = + { { "awesome", myawesomemenu, beautiful.awesome_icon }, + { "Debian", debian.menu.Debian_menu.Debian }, + { "open terminal", terminal }, + { "log out", function () sessionmethod "--logout" end }, + { "shut down", function () sessionmethod "--power-off" end }, + } + }) + +mylauncher = awful.widget.launcher({ image = beautiful.awesome_icon, + menu = mymainmenu }) +-- }}} + +-- {{{ Wibox +-- Create a textclock widget +mytextclock = awful.widget.textclock() +-- Calendar tooltip currently doesn't render. Oddness +--cal.register(mytextclock, "<b>%s</b>") + +-- Create a wibox for each screen and add it +mywibox = {} +mypromptbox = {} +mylayoutbox = {} +mytaglist = {} +mytaglist.buttons = tjoin( + awful.button({ }, 1, awful.tag.viewonly), + awful.button({ modkey }, 1, awful.client.movetotag), + awful.button({ }, 3, awful.tag.viewtoggle), + awful.button({ modkey }, 3, awful.client.toggletag) + -- awful.button({ }, 4, awful.tag.viewnext), + -- awful.button({ }, 5, awful.tag.viewprev) + ) +mytasklist = {} +mytasklist.buttons = + tjoin( + awful.button({ }, 1, function (c) + if c == client.focus then + c.minimized = true + else + if not c:isvisible() then + awful.tag.viewonly(c:tags()[1]) + end + -- This will also un-minimize + -- the client, if needed + client.focus = c + c:raise() + end + end), + awful.button({ }, 3, function () + if instance then + instance:hide() + instance = nil + else + instance = awful.menu.clients({ width=250 }) + end + end), + awful.button({ }, 4, function () + awful.client.focus.byidx(1) + if client.focus then client.focus:raise() end + end), + awful.button({ }, 5, function () + awful.client.focus.byidx(-1) + if client.focus then client.focus:raise() end + end)) + +for s = 1, screen.count() do + -- Create a promptbox for each screen + mypromptbox[s] = awful.widget.prompt() + -- Create an imagebox widget which will contains an icon indicating which layout we're using. + -- We need one layoutbox per screen. + mylayoutbox[s] = awful.widget.layoutbox(s) + local function layout_button(n, m) + return awful.button({}, n, function () awful.layout.inc(layouts, m) end) + end + mylayoutbox[s]:buttons(tjoin( + layout_button(1, 1), + layout_button(3, -1), + layout_button(4, 1), + layout_button(4, -1))) + -- Create a taglist widget + mytaglist[s] = + awful.widget.taglist(s, awful.widget.taglist.filter.all, mytaglist.buttons) + + -- Create a tasklist widget + mytasklist[s] = + awful.widget.tasklist(s, awful.widget.tasklist.filter.currenttags, mytasklist.buttons) + + -- Create the wibox + mywibox[s] = awful.wibox({ position = "top", screen = s }) + + -- Widgets that are aligned to the left + local left_layout = wibox.layout.fixed.horizontal() + left_layout:add(mylauncher) + left_layout:add(mytaglist[s]) + left_layout:add(mypromptbox[s]) + + -- Widgets that are aligned to the right + local right_layout = wibox.layout.fixed.horizontal() + if s == 1 then right_layout:add(wibox.widget.systray()) end + right_layout:add(mytextclock) + right_layout:add(mylayoutbox[s]) + + -- Now bring it all together (with the tasklist in the middle) + local layout = wibox.layout.align.horizontal() + layout:set_left(left_layout) + layout:set_middle(mytasklist[s]) + layout:set_right(right_layout) + + mywibox[s]:set_widget(layout) +end +-- }}} + +-- {{{ Key bindings +globalkeys = keysetup.globalkeys(modkey, mypromptbox) + +clientkeys = keysetup.clientkeys(modkey) + +clientbuttons = tjoin( + awful.button({ }, 1, function (c) client.focus = c; c:raise() end), + awful.button({ modkey }, 1, awful.mouse.client.move), + awful.button({ modkey }, 3, awful.mouse.client.resize)) + +-- Set keys +root.keys(globalkeys) +shifty.config.globalkeys = globalkeys +shifty.config.clientkeys = clientkeys +-- }}} + +shiftyconfig.go(modkey) + +shifty.layouts = layouts +shifty.taglist = mytaglist +shifty.init() + + + +-- {{{ Mouse bindings +root.buttons(tjoin( + awful.button({ }, 3, function () mymainmenu:toggle() end) +-- awful.button({ }, 4, awful.tag.viewnext), +-- awful.button({ }, 5, awful.tag.viewprev) + )) +-- }}} + + +-- {{{ Signals +-- Signal function to execute when a new client appears. +do + function ___(c, startup) + -- Enable sloppy focus + reloader.try_place_client(c, startup) + c:connect_signal("mouse::enter", + function(c) + if awful.layout.get(c.screen) ~= awful.layout.suit.magnifier + and awful.client.focus.filter(c) then + client.focus = c + end + end) + + end + client.connect_signal("manage", ___) +end +client.connect_signal("focus", function(c) c.border_color = beautiful.border_focus end) +client.connect_signal("unfocus", function(c) c.border_color = beautiful.border_normal end) +-- }}} + +-- Finally, let the reloader in on the game + +reloader.prepare_reload_state "/home/dsilvers/.config/awesome/client.state" diff --git a/awesomerc/rc-git/keysetup.lua b/awesomerc/rc-git/keysetup.lua new file mode 100644 index 0000000..bfe8e52 --- /dev/null +++ b/awesomerc/rc-git/keysetup.lua @@ -0,0 +1,165 @@ +module(..., package.seeall) + +local awful = require 'awful' +local djas = require 'djas' +local shifty = require 'shifty' + +local tjoin = awful.util.table.join + +local keyjoiner_methods = {} + +function keyjoiner_methods:oldact(mods, key, action) + if (mods ~= nil) then + self.keys = + tjoin(self.keys, + awful.key(mods, key, action)) + end + return self.keys +end + +function keyjoiner_methods:act(key, action) + if key ~= nil then + assert(action, "Unable to act if there's no action") + local mods = {} + local _ + local map = { + C = "Control", + S = "Shift", + A = "Mod1", + M = self.modkey, + } + while key:match("^[CSMA]%-") do + _, _, prefix, key = key:find("^(.)%-(.+)$") + mods[#mods+1] = map[prefix] + end + if key:match("^[0-9]$") then + key = tonumber(key) + end + self.keys = tjoin(self.keys, + awful.key(mods, key, action)) + end + return self.keys +end + +local keyjoiner_meta = { + __index = keyjoiner_methods, + __call = keyjoiner_methods.oldact, +} + +function keyjoiner_new(modkey) + return setmetatable({modkey = modkey, keys={}}, keyjoiner_meta) +end + +function clientkeys(modkey) + local lockeys = keyjoiner_new(modkey) + lockeys:act("C-S-A-Left", djas.warpprev) + lockeys:act("C-S-A-Right", djas.warpnext) + lockeys:act("M-f", function (c) c.fullscreen = not c.fullscreen end) + lockeys:act("A-F4", function(c) c:kill() end) + + lockeys:act("M-C-space", awful.client.floating.toggle) + lockeys:act("C-M-Return", function (c) c:swap(awful.client.getmaster()) end) + lockeys:act("M-o", awful.client.movetoscreen) + lockeys:act("C-S-A-Up", awful.client.movetoscreen) + lockeys:act("C-S-A-Down", awful.client.movetoscreen) + lockeys:act("M-t", function (c) c.ontop = not c.ontop end) + do + local function maximiser (c) + c.maximized_horizontal = not c.maximized_horizontal + c.maximized_vertical = not c.maximized_vertical + end + lockeys:act("M-m", maximiser) + lockeys:act("C-S-F11", maximiser) + end + + return lockeys() +end + +local function speshulterminal(t,e) + awful.util.spawn("gnome-terminal --role " .. t .. " --title " .. t .. " -e " .. e, false) +end + +function globalkeys(modkey,mypromptbox) + local globkeys = keyjoiner_new(modkey) + globkeys:act("C-A-M-m", + function() + speshulterminal("Mutt", "mutt") + speshulterminal("OfflineIMAP", "offlineimap") + end) + globkeys:act("C-A-Left", awful.tag.viewprev) + globkeys:act("C-A-Right", awful.tag.viewnext) + globkeys:act("C-M-Left", shifty.shift_prev) + globkeys:act("C-M-Right", shifty.shift_next) + globkeys:act("M-t", function() shifty.add({ rel_index = 1 }) end) + globkeys:act("C-M-t", function() shifty.add({ rel_index = 1, nopopup = true }) end) + globkeys:act("M-r", shifty.rename) + globkeys:act("M-w", shifty.del) + globkeys:act("M-Escape", awful.tag.history.restore) + + globkeys:act("M-j", function () + awful.client.focus.byidx( 1) + if client.focus then client.focus:raise() end + end) + globkeys:act("M-k", function () + awful.client.focus.byidx(-1) + if client.focus then client.focus:raise() end + end) + globkeys:act("M-Menu", function () mymainmenu:show({keygrabber=true}) end) + + -- Layout manipulation + globkeys:act("M-S-j", function () awful.client.swap.byidx( 1) end) + globkeys:act("M-S-k", function () awful.client.swap.byidx( -1) end) + globkeys:act("M-C-j", function () awful.screen.focus_relative( 1) end) + globkeys:act("M-C-k", function () awful.screen.focus_relative(-1) end) + globkeys:act("C-A-Up", function () awful.screen.focus_relative( 1) end) + globkeys:act("C-A-Down", function () awful.screen.focus_relative(-1) end) + globkeys:act("M-u", awful.client.urgent.jumpto) + globkeys:act("M-Tab", function () + awful.client.focus.history.previous() + if client.focus then + client.focus:raise() + end + end) + + -- Standard program + globkeys:act("M-x", function () awful.util.spawn(terminal) end) + globkeys:act("M-C-r", awesome.restart) + globkeys:act("M-C-n", awful.client.restore) + + -- Prompt + globkeys:act("A-F2", function () mypromptbox[mouse.screen]:run() end) + globkeys:act("M-C-x", + function () + awful.prompt.run({ prompt = "Run Lua code: " }, + mypromptbox[mouse.screen].widget, + awful.util.eval, nil, + awful.util.getdir("cache") .. "/history_eval") + end) + -- Tag switching + for i=1,9 do + local function si(p) + return p .. "-" .. tostring(i) + end + globkeys:act(si "M", function () + local t = awful.tag.viewonly(shifty.getpos(i)) + end) + globkeys:act(si "M-C", function () + local t = shifty.getpos(i) + t.selected = not t.selected + end) + globkeys:act(si "M-C-S", function () + if client.focus then + awful.client.toggletag(shifty.getpos(i)) + end + end) + -- move clients to other tags + globkeys:act(si "M-S", function () + if client.focus then + local t = shifty.getpos(i) + awful.client.movetotag(t) + awful.tag.viewonly(t) + end + end) + end + return globkeys() +end diff --git a/awesomerc/rc-git/naughtyaugment.lua b/awesomerc/rc-git/naughtyaugment.lua new file mode 100644 index 0000000..12fefbd --- /dev/null +++ b/awesomerc/rc-git/naughtyaugment.lua @@ -0,0 +1,49 @@ +local barexml = [=[<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object + Introspection 1.0//EN" + "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"> + <node> + <interface name="org.freedesktop.DBus.Introspectable"> + <method name="Introspect"> + <arg name="xml_data" type="s" direction="out"/> + </method> + </interface> + </node> +]=] + +local function _retxml(nextnode) + return [=[<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object + Introspection 1.0//EN" + "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"> + <node> + <interface name="org.freedesktop.DBus.Introspectable"> + <method name="Introspect"> + <arg name="xml_data" type="s" direction="out"/> + </method> + </interface> + <node name="]=] .. nextnode .. [=[" /> + </node> +]=] +end + +local function _introspect_cb(data, text) + if data.member == "Introspect" then + local nextnode + if data.path == "/" then + nextnode = "org" + elseif data.path == "/org" then + nextnode = "freedesktop" + elseif data.path == "/org/freedesktop" then + nextnode = "Notifications" + else + return "s", barexml + end + return "s", _retxml(nextnode) + end +end + +local function _property_cb(data, text) +end + +dbus.connect_signal("", _introspect_cb) +dbus.connect_signal("org.freedesktop.DBus.Properties", _property_cb) + diff --git a/awesomerc/rc-git/reloader.lua b/awesomerc/rc-git/reloader.lua new file mode 100644 index 0000000..59230a6 --- /dev/null +++ b/awesomerc/rc-git/reloader.lua @@ -0,0 +1,300 @@ +-- Facility to dump out a file describing all the clients attached to +-- awesome, all the tags on all the screens, and to allow that to then +-- be re-created on restart. +-- +-- Essentially to allow restarts of awesome with as close to +-- the currently running shape as possible +-- + +module(..., package.seeall) + +function print(...) + local space = "" + for _, v in ipairs{...} do + io.stderr:write(space, tostring(v)) + space = "\t" + end + io.stderr:write("\n") + io.stderr:flush() +end + +local layoutname = { + [awful.layout.suit.floating] = "floating", + [awful.layout.suit.fair] = "fair", + [awful.layout.suit.tile] = "tile", + [awful.layout.suit.max] = "max", + [awful.layout.suit.spiral] = "spiral", + [awful.layout.suit.magnifier] = "magnifier", +} + +local function _dumpstate(f) + local space = "" + f:write("-- Screens\n\n") + local tagmap = {} + for i = 1, screen.count() do + local scr = screen[i] + -- To identify a screen, we can't rely on its index, instead we + -- rely on its geometry, initially we consider its width and + -- height only and if that is ambiguous then we use its x/y, but + -- this is only during restoration anyway. + f:write("DefineScreen {\n") + local geom = scr.geometry + f:write(" geometry = {") + space = "" + for _, v in ipairs{"x","y","width","height"} do + f:write(space, v, " = ", tostring(geom[v])) + space = ", " + end + f:write("},\n") + local tags = scr:tags() + f:write(" tags = {") + space = "\n " + for _, tag in ipairs(tags) do + tagmap[#tagmap+1] = tag + tagmap[tag] = #tagmap + f:write(("%s{ id = %d, name = %q,\n props = {\n"):format(space, #tagmap, tag.name)) + for k, v in pairs(awful.tag.getdata(tag) or {}) do + if k ~= "layout" then + if type(v) == "string" then + v = ("%q"):format(v) + else + v = tostring(v) + end + f:write((" [%q] = %s,\n"):format(k, v)) + end + end + local layout = awful.tag.getproperty(tag, "layout") + f:write(" layout = awful.layout.suit.", layoutname[layout] or "floating", "\n }\n") + f:write(" }") + space = ",\n " + end + f:write("\n },\n") + f:write(" id = ", tostring(i), "\n}\n\n") + end + f:write("\n\n-- Clients\n\n") + local all_clients = client.get(); + for _, c in ipairs(all_clients) do + f:write("DefineClient {\n") + f:write(" -- ", tostring(c.name), " [", tostring(c.class), "/", tostring(c.instance), "]\n") + f:write(" screen = ", tostring(c.screen), ",\n") + f:write(" tags = { ") + space = "" + for _, tag in ipairs(c:tags()) do + f:write(("%s%d"):format(space, tagmap[tag])) + space = ", " + end + f:write(" },\n") + local geom = c:geometry() + f:write(" geometry = {") + space = "" + for _, v in ipairs{"x","y","width","height"} do + f:write(space, v, " = ", tostring(geom[v])) + space = ", " + end + f:write("},\n") + for _, prop in ipairs{"maximized_vertical", "maximized_horizontal", "minimized"} do + -- boolean property + f:write(" ", prop, " = ", (c[prop] and "true" or "false"), ",\n") + end + f:write(" id = ", tostring(c.window), "\n}\n\n") + end +end + +local function dump_awesome_state(fname) + local f = io.open(fname, "w") + local ok, msg = pcall(_dumpstate, f) + if not ok then + f:write("\n\n-- ", msg, "\n\n") + f:close() + -- os.execute(("rm -f %q"):format(fname)) + return false + end + f:close() + return true +end + +local reloader_filename + +local function reloader_atexit(is_restart) + print "reloader: atexit" + if is_restart then + print "reloader: restart indicated" + dump_awesome_state(reloader_filename) + else + print "reloader: restart not indicated" + end +end + +local client_screen_map = {} +local client_tag_map = setmetatable({}, { __mode = "v" }) +local client_data_map = {} + +local function load_restore_state(f) + local func = assert(loadfile(f)) + print ("reloader: Loaded configuration from " .. f) + local screens, clients = {}, {} + + local function _DefineScreen(s) + screens[#screens+1] = s + end + + local function _DefineClient(c) + clients[#clients+1] = c + end + + setfenv(func, setmetatable({ + DefineScreen = _DefineScreen, + DefineClient = _DefineClient + }, { __index = _G })) + + func() + + print("reloader: Defined", #screens, "screens and ", #clients, "clients") + local screenmap = client_screen_map + for _, thisscreen in ipairs(screens) do + -- Attempt to match this screen to the real screens + print("reloader: Attempting to match geometry for incoming screen ", thisscreen.id) + local thisgeom = thisscreen.geometry + local foundscreen + for i = 1, screen.count() do + local scr = screen[i] + local scrgeom = scr.geometry + if thisgeom.x == scrgeom.x and + thisgeom.y == scrgeom.y and + thisgeom.width == scrgeom.width and + thisgeom.height == scrgeom.height then + foundscreen = i + end + end + if not foundscreen then + for i = 1, screen.count() do + local scr = screen[i] + local scrgeom = scr.geometry + if thisgeom.width == scrgeom.width and + thisgeom.height == scrgeom.height then + foundscreen = i + end + end + end + if not foundscreen then + -- If we've not found a candidate then drop it onto screen 1 + foundscreen = 1 + end + print("reloader: Mapping screen", thisscreen.id, "to", foundscreen) + screenmap[thisscreen.id] = foundscreen + end + -- We've mapped the screens, so now we run through, preparing the tags + -- We merge tags which were named the same if they fold onto screen 1 + local folding_tag_map = {} + for i = 1, screen.count() do + folding_tag_map[i] = { _byid = {}} + end + for _, thisscreen in ipairs(screens) do + for _, tagtab in ipairs(thisscreen.tags) do + tagtab.props.name = tagtab.name + local newtag = (folding_tag_map[screenmap[thisscreen.id]][tagtab.name] or + shifty.add(tagtab.props)) + print("reloader: tag", newtag, "is", tagtab.name, "on", thisscreen.id, "[",screenmap[thisscreen.id], "]") + if not folding_tag_map[screenmap[thisscreen.id]][tagtab.name] then + folding_tag_map[screenmap[thisscreen.id]][tagtab.name] = newtag + local by = folding_tag_map[screenmap[thisscreen.id]]._byid + by[#by+1] = newtag + print("reloader: that tag is nr", #by, "on my list") + end + -- The client tag map has weak values which means that + -- the result might be nil on read + client_tag_map[tagtab.id] = newtag + end + end + -- Tags are folded and prepped, assign them to screens + for i = 1, screen.count() do + --[[ -- Seems to be bullshit + print("reloader: clearing tags for screen", i) + local tags_to_del = screen[i]:tags() + for i, tag in ipairs(tags_to_del) do + print("reloader: dumping tag", tag) + shifty.del(tag) + end + --]] + assert(next(folding_tag_map[i]._byid), "No tags for screen " .. tostring(i)) + screen[i]:tags(folding_tag_map[i]._byid) + awful.tag.viewonly(folding_tag_map[i]._byid[1]) + end + -- Right now, there's probably no clients (phew) so we'll not + -- worry too much about assigning them anywhere. + -- Just build the client_data_map for try_place_client later + for _, thisclient in ipairs(clients) do + print("reloader: defined client", thisclient.id) + client_data_map[tonumber(thisclient.id)] = thisclient + end + -- Aaaand we're done +end + +function prepare_reload_state(fname) + -- The filename is where the reloader state will be. + reloader_filename = fname + local f = io.open(fname, "r") + if f then + f:close() + local ok, msg = pcall(load_restore_state, fname) + if not ok then + naughty.notify { title = "Failure restoring state", text = msg } + print("reloader: Error loading",fname,"::",msg) + -- Zero off any client map + client_data_map = {} + end + os.execute(("mv %q %q"):format(fname, fname .. ".old")) + end + -- Either way, register the atexit + print "reloader: connecting atexit" + awesome.connect_signal("exit", reloader_atexit) +end + +function try_place_client(c, startup) + -- Perform a client placement if we can find hints for it This is + -- done *only* during startup management. Startup management is + -- done during awesome startup. so it will only happen once we're + -- loaded and then reloaded. + if not startup then return end + print("placement: Attempting to place", c.window) + local datamap = client_data_map[tonumber(c.window)] + if datamap then + client_data_map[c.window] = nil + else + print("placement: Could not find mapping for", c.window) + return + end + -- Apply the settings from the map to the client. + -- First, make sure it's on the right tag and screen + c.screen = client_screen_map[datamap.screen] + print("placement: Client asked for screen", datamap.screen, + "which is really screen", c.screen) + local tags, tagset = {}, {} + for _, id in ipairs(datamap.tags) do + local thistag = client_tag_map[id] + print("placement: Client in tag", id, "which is", thistag) + if not thistag then + -- if we failed to map this tag, we treat it as the first + -- tag on the first screen + thistag = screen[c.screen]:tags()[1] + end + if not tagset[thistag] then + tags[#tags+1] = thistag + tagset[thistag] = true + end + end + if #tags == 0 then + print("placement: Could not identify tag, defaulting...") + tags[1] = screen[c.screen]:tags()[1] + end + c:tags(tags) + -- Now apply geometry + c:geometry(datamap.geometry) + -- Now the boolean properties + for _, prop in ipairs{"maximized_horizontal", "maximized_vertical", "minimized"} do + print("placement: setting",prop,"to",datamap[prop]) + c[prop] = datamap[prop] + end + -- We're done restoring this client. Woop Woop Woop +end + diff --git a/awesomerc/rc-git/shifty.lua b/awesomerc/rc-git/shifty.lua new file mode 100644 index 0000000..510c1ef --- /dev/null +++ b/awesomerc/rc-git/shifty.lua @@ -0,0 +1,845 @@ +--- Shifty: Dynamic tagging library for awesome3-git +-- @author koniu <gkusnierz@gmail.com> +-- @author bioe007 <perry.hargrave@gmail.com> +-- +-- http://awesome.naquadah.org/wiki/index.php?title=Shifty + +-- {{{ environment +local type = type +local ctag = tag +local ipairs = ipairs +local table = table +local client = client +local image = image +local string = string +local screen = screen +local button = button +local mouse = mouse +local beautiful = require("beautiful") +local awful = require("awful") +local pairs = pairs +local io = io +local tonumber = tonumber +local wibox = wibox +local root = root +local dbg= dbg +local timer = timer +local assert = assert +local tostring = tostring +local lselect = select + +module("shifty") +-- }}} + +-- {{{ variables +config = {} +config.tags = {} +config.apps = {} +config.defaults = {} +config.guess_name = true +config.guess_position = true +config.remember_index = true +config.default_name = "new" +config.clientkeys = {} +config.globalkeys = nil +config.layouts = {} +config.prompt_sources = { "config_tags", "config_apps", "existing", "history" } +config.prompt_matchers = { "^", ":", "" } + +local matchp = "" +local index_cache = {} +for i = 1, screen.count() do index_cache[i] = {} end +-- }}} + +--{{{ name2tags: matches string 'name' to tag objects +-- @param name : tag name to find +-- @param scr : screen to look for tags on +-- @return table of tag objects or nil +function name2tags(name, scr) + local ret = {} + local a, b = scr or 1, scr or screen.count() + for s = a, b do + for i, t in ipairs(screen[s]:tags()) do + if name == t.name then + table.insert(ret, t) + end + end + end + if #ret > 0 then return ret end +end + +function name2tag(name, scr, idx) + local ts = name2tags(name, scr) + if ts then return ts[idx or 1] end +end +--}}} + +--{{{ tag2index: finds index of a tag object +-- @param scr : screen number to look for tag on +-- @param tag : the tag object to find +-- @return the index [or zero] or end of the list +function tag2index(scr, tag) + local scrn = screen[scr] + local tags = scrn:tags() + for i,t in ipairs(tags) do + if t == tag then return i end + end +end +--}}} + +--{{{ rename +--@param tag: tag object to be renamed +--@param prefix: if any prefix is to be added +--@param no_selectall: +function rename(tag, prefix, no_selectall) + local theme = beautiful.get() + local t = tag or awful.tag.selected(mouse.screen) + local scr = t.screen + local bg = nil + local fg = nil + local text = prefix or t.name + local before = t.name + + if t == awful.tag.selected(scr) then + bg = theme.bg_focus or '#535d6c' + fg = theme.fg_urgent or '#ffffff' + else + bg = theme.bg_normal or '#222222' + fg = theme.fg_urgent or '#ffffff' + end + + local textwidget = taglist[scr].widgets[tag2index(scr,t)].widget.widgets[2].widget + + awful.prompt.run( { + fg_cursor = fg, bg_cursor = bg, ul_cursor = "single", + text = text, selectall = not no_selectall }, + textwidget, + function (name) if name:len() > 0 then t.name = name; end end, + completion, + awful.util.getdir("cache") .. "/history_tags", nil, + function () + if t.name == before then + if awful.tag.getproperty(t, "initial") then del(t) end + else + awful.tag.setproperty(t, "initial", true) + set(t) + end + tagkeys(screen[scr]) + t:emit_signal("property::name") + end + ) +end +--}}} + +--{{{ send: moves client to tag[idx] +-- maybe this isn't needed here in shifty? +-- @param idx the tag number to send a client to +function send(idx) + local scr = client.focus.screen or mouse.screen + local sel = awful.tag.selected(scr) + local sel_idx = tag2index(scr,sel) + local tags = screen[scr]:tags() + local target = awful.util.cycle(#tags, sel_idx + idx) + awful.client.movetotag(tags[target], client.focus) + awful.tag.viewonly(tags[target]) +end + +function send_next() send(1) end +function send_prev() send(-1) end +--}}} + +--{{{ pos2idx: translate shifty position to tag index +--@param pos: position (an integer) +--@param scr: screen number +function pos2idx(pos, scr) + local v = 1 + if pos and scr then + for i = #screen[scr]:tags() , 1, -1 do + local t = screen[scr]:tags()[i] + if awful.tag.getproperty(t,"position") and awful.tag.getproperty(t,"position") <= pos then + v = i + 1 + break + end + end + end + return v +end +--}}} + +--{{{ select : helper function chooses the first non-nil argument +--@param args - table of arguments +function select(args) + for i, a in pairs(args) do + if a ~= nil then + return a + end + end +end +--}}} + +--{{{ tagtoscr : move an entire tag to another screen +-- +--@param scr : the screen to move tag to +--@param t : the tag to be moved [awful.tag.selected()] +--@return the tag +function tagtoscr(scr, t) + -- break if called with an invalid screen number + if not scr or scr < 1 or scr > screen.count() then return end + -- tag to move + local otag = t or awful.tag.selected() + + -- set screen and then reset tag to order properly + if #otag:clients() > 0 then + for _ , c in ipairs(otag:clients()) do + if not c.sticky then + c.screen = scr + c:tags( { otag } ) + else + awful.client.toggletag(otag,c) + end + end + end + return otag +end +---}}} + +--{{{ set : set a tags properties +--@param t: the tag +--@param args : a table of optional (?) tag properties +--@return t - the tag object +function set(t, args) + if not t then return end + if not args then args = {} end + + -- set the name + t.name = args.name or t.name + + -- attempt to load preset on initial run + local preset = (awful.tag.getproperty(t, "initial") and config.tags[t.name]) or {} + + -- pick screen and get its tag table + local scr = args.screen or (not t.screen and preset.screen) or t.screen or mouse.screen + if scr > screen.count() then scr = screen.count() end + if t.screen and scr ~= t.screen then + tagtoscr(scr, t) + t.screen = nil + end + local tags = screen[scr]:tags() + + -- try to guess position from the name + local guessed_position = nil + if not (args.position or preset.position) and config.guess_position then + local num = t.name:find('^[1-9]') + if num then guessed_position = tonumber(t.name:sub(1,1)) end + end + + -- select from args, preset, getproperty, config.defaults.configs or defaults + local props = { + layout = select{ args.layout, preset.layout, awful.tag.getproperty(t,"layout"), config.defaults.layout, awful.layout.suit.tile }, + mwfact = select{ args.mwfact, preset.mwfact, awful.tag.getproperty(t,"mwfact"), config.defaults.mwfact, 0.55 }, + nmaster = select{ args.nmaster, preset.nmaster, awful.tag.getproperty(t,"nmaster"), config.defaults.nmaster, 1 }, + ncol = select{ args.ncol, preset.ncol, awful.tag.getproperty(t,"ncol"), config.defaults.ncol, 1 }, + matched = select{ args.matched, awful.tag.getproperty(t,"matched") }, + exclusive = select{ args.exclusive, preset.exclusive, awful.tag.getproperty(t,"exclusive"), config.defaults.exclusive }, + persist = select{ args.persist, preset.persist, awful.tag.getproperty(t,"persist"), config.defaults.persist }, + nopopup = select{ args.nopopup, preset.nopopup, awful.tag.getproperty(t,"nopopup"), config.defaults.nopopup }, + leave_kills = select{ args.leave_kills, preset.leave_kills, awful.tag.getproperty(t,"leave_kills"), config.defaults.leave_kills }, + max_clients = select{ args.max_clients, preset.max_clients, awful.tag.getproperty(t,"max_clients"), config.defaults.max_clients }, + position = select{ args.position, preset.position, guessed_position, awful.tag.getproperty(t,"position" ) }, + icon = select{ args.icon and image(args.icon), preset.icon and image(preset.icon), awful.tag.getproperty(t,"icon"), config.defaults.icon and image(config.defaults.icon) }, + icon_only = select{ args.icon_only, preset.icon_only, awful.tag.getproperty(t,"icon_only"), config.defaults.icon_only }, + sweep_delay = select{ args.sweep_delay, preset.sweep_delay, awful.tag.getproperty(t,"sweep_delay"), config.defaults.sweep_delay }, + overload_keys = select{ args.overload_keys, preset.overload_keys, awful.tag.getproperty(t,"overload_keys"), config.defaults.overload_keys }, + } + + -- get layout by name if given as string + if type(props.layout) == "string" then + props.layout = getlayout(props.layout) + end + + -- set keys + if args.keys or preset.keys then + local keys = awful.util.table.join(config.globalkeys, args.keys or preset.keys) + if props.overload_keys then + props.keys = keys + else + props.keys = squash_keys(keys) + end + end + + -- calculate desired taglist index + local index = args.index or preset.index or config.defaults.index + local rel_index = args.rel_index or preset.rel_index or config.defaults.rel_index + local sel = awful.tag.selected(scr) + local sel_idx = (sel and tag2index(scr,sel)) or 0 --TODO: what happens with rel_idx if no tags selected + local t_idx = tag2index(scr,t) + local limit = (not t_idx and #tags + 1) or #tags + local idx = nil + + if rel_index then + idx = awful.util.cycle(limit, (t_idx or sel_idx) + rel_index) + elseif index then + idx = awful.util.cycle(limit, index) + elseif props.position then + idx = pos2idx(props.position, scr) + if t_idx and t_idx < idx then idx = idx - 1 end + elseif config.remember_index and index_cache[scr][t.name] then + idx = index_cache[scr][t.name] + elseif not t_idx then + idx = #tags + 1 + end + + -- if we have a new index, remove from old index and insert + if idx then + if t_idx then table.remove(tags, t_idx) end + table.insert(tags, idx, t) + index_cache[scr][t.name] = idx + end + + -- set tag properties and push the new tag table + screen[scr]:tags(tags) + for prop, val in pairs(props) do awful.tag.setproperty(t, prop, val) end + + -- execute run/spawn + if awful.tag.getproperty(t, "initial") then + local spawn = args.spawn or preset.spawn or config.defaults.spawn + local run = args.run or preset.run or config.defaults.run + if spawn and args.matched ~= true then awful.util.spawn_with_shell(spawn, scr) end + if run then run(t) end + awful.tag.setproperty(t, "initial", nil) + end + + return t +end + +function shift_next() set(awful.tag.selected(), { rel_index = 1 }) end +function shift_prev() set(awful.tag.selected(), { rel_index = -1 }) end +--}}} + +--{{{ add : adds a tag +--@param args: table of optional arguments +-- +function add(args) + if not args then args = {} end + local name = args.name or " " + + -- initialize a new tag object and its data structure + local t = ctag{ name = name } + + -- tell set() that this is the first time + awful.tag.setproperty(t, "initial", true) + + -- apply tag settings + set(t, args) + + -- unless forbidden or if first tag on the screen, show the tag + if not (awful.tag.getproperty(t,"nopopup") or args.noswitch) or #screen[t.screen]:tags() == 1 then awful.tag.viewonly(t) end + + -- get the name or rename + if args.name then + t.name = args.name + else + -- FIXME: hack to delay rename for un-named tags for tackling taglist refresh + -- which disabled prompt from being rendered until input + awful.tag.setproperty(t, "initial", true) + local f + if args.position then + f = function() rename(t, args.rename, true); tmr:stop() end + else + f = function() rename(t); tmr:stop() end + end + tmr = timer({ timeout = 0.01 }) + tmr:connect_signal("timeout", f) + tmr:start() + end + + return t +end +--}}} + +--{{{ del : delete a tag +--@param tag : the tag to be deleted [current tag] +function del(tag) + local scr = (tag and tag.screen) or mouse.screen or 1 + local tags = screen[scr]:tags() + local sel = awful.tag.selected(scr) + local t = tag or sel + local idx = tag2index(scr,t) + + -- return if tag not empty (except sticky) + local clients = t:clients() + local sticky = 0 + for i, c in ipairs(clients) do + if c.sticky then sticky = sticky + 1 end + end + if #clients > sticky then return end + + -- store index for later + index_cache[scr][t.name] = idx + + -- remove tag + t.screen = nil + + -- if the current tag is being deleted, restore from history + if t == sel and #tags > 1 then + awful.tag.history.restore(scr,1) + -- this is supposed to cycle if history is invalid? + -- e.g. if many tags are deleted in a row + if not awful.tag.selected(scr) then + awful.tag.viewonly(tags[awful.util.cycle(#tags, idx - 1)]) + end + end + + -- FIXME: what is this for?? + if client.focus then client.focus:raise() end +end +--}}} + +function print(...) + do return end + local t = {...} + local n = lselect("#",...) + io.stderr:write(tostring(t[1])) + for i = 2,n do + io.stderr:write("\t" .. tostring(t[i])) + end + io.stderr:write("\n") +end + +--{{{ match : handles app->tag matching, a replacement for the manage hook in +-- rc.lua +--@param c : client to be matched +function match(c, startup) + local nopopup, intrusive, nofocus, run, slave, wfact, struts, geom, float + local target_tag_names, target_tags = {}, {} + local typ = c.type + local cls = c.class + local inst = c.instance + local role = c.role + local name = c.name + local keys = config.clientkeys or c:keys() or {} + local target_screen = mouse.screen + + run = {} + + c.border_color = beautiful.border_normal + c.border_width = beautiful.border_width + + print("New Client!") + print("Class", cls) + print("Instance", instance) + print("Role", role) + print("Name", name) + print("Type", typ) + print("Here we go...") + + -- try matching client to config.apps + for i, a in ipairs(config.apps) do + if a.match then + for k, w in ipairs(a.match) do + print("Considering", w) + if + (cls and cls:find(w)) or + (inst and inst:find(w)) or + (name and name:find(w)) or + (role and role:find(w)) or + (typ and typ:find(w)) + then + print("Woop, useful stuffs here") + if a.screen then target_screen = a.screen end + if a.tag then + if type(a.tag) == "string" then + target_tag_names = { a.tag } + else + target_tag_names = a.tag + end + end + if a.startup and startup then a = awful.util.table.join(a, a.startup) end + if a.geometry ~=nil then geom = { x = a.geometry[1], y = a.geometry[2], width = a.geometry[3], height = a.geometry[4] } end + if a.float ~= nil then float = a.float end + if a.slave ~=nil then slave = a.slave end + if a.border_width ~= nil then c.border_width = a.border_width end + if a.nopopup ~=nil then nopopup = a.nopopup end + if a.intrusive ~=nil then intrusive = a.intrusive end + if a.fullscreen ~=nil then c.fullscreen = a.fullscreen end + if a.honorsizehints ~=nil then c.size_hints_honor = a.honorsizehints end + if a.kill ~=nil then c:kill(); return end + if a.ontop ~= nil then c.ontop = a.ontop end + if a.above ~= nil then c.above = a.above end + if a.below ~= nil then c.below = a.below end + if a.buttons ~= nil then c:buttons(a.buttons) end + if a.nofocus ~= nil then nofocus = a.nofocus end + if a.keys ~= nil then keys = awful.util.table.join(keys, a.keys) end + if a.hidden ~= nil then c.hidden = a.hidden end + if a.minimized ~= nil then c.minimized = a.minimized end + if a.dockable ~= nil then awful.client.dockable.set(c, a.dockable) end + if a.urgent ~= nil then c.urgent = a.urgent end + if a.opacity ~= nil then c.opacity = a.opacity end + if a.run ~= nil then run[#run+1] = a.run end + if a.sticky ~= nil then c.sticky = a.sticky end + if a.wfact ~= nil then wfact = a.wfact end + if a.struts then struts = a.struts end + if a.skip_taskbar ~= nil then c.skip_taskbar = a.skip_taskbar end + if a.props then + for kk, vv in pairs(a.props) do awful.client.property.set(c, kk, vv) end + end + end + end + end + end + + print("Finished?") + + -- set key bindings + c:keys(keys) + + -- set properties of floating clients + if awful.client.floating.get(c) then + awful.placement.centered(c, c.transient_for) + awful.placement.no_offscreen(c) -- this always seems to stick the client at 0,0 (incl titlebar) + end + + -- if not matched to some names try putting client in c.transient_for or current tags + local sel = awful.tag.selectedlist(target_screen) + if not target_tag_names or #target_tag_names == 0 then + if c.transient_for then + target_tags = c.transient_for:tags() + elseif #sel > 0 then + for i, t in ipairs(sel) do + local mc = awful.tag.getproperty(t,"max_clients") + if not (awful.tag.getproperty(t,"exclusive") or (mc and mc >= #t:clients())) or intrusive then + table.insert(target_tags, t) + end + end + end + end + + -- if we still don't know any target names/tags guess name from class or use default + if (not target_tag_names or #target_tag_names == 0) and (not target_tags or #target_tags == 0) then + if config.guess_name and cls then + target_tag_names = { cls:lower() } + else + target_tag_names = { config.default_name } + end + end + + -- translate target names to tag objects, creating missing ones + if #target_tag_names > 0 and #target_tags == 0 then + for i, tn in ipairs(target_tag_names) do + local res = {} + for j, t in ipairs(name2tags(tn, target_screen) or name2tags(tn) or {}) do + local mc = awful.tag.getproperty(t,"max_clients") + if not (mc and (#t:clients() >= mc)) or intrusive then + table.insert(res, t) + end + end + if #res == 0 then + table.insert(target_tags, add({ name = tn, noswitch = true, matched = true })) + else + target_tags = awful.util.table.join(target_tags, res) + end + end + end + + -- set client's screen/tag if needed + target_screen = target_tags[1].screen or target_screen + if c.screen ~= target_screen then c.screen = target_screen end + if slave then awful.client.setslave(c) end + c:tags( target_tags ) + if wfact then awful.client.setwfact(wfact, c) end + if float ~= nil then awful.client.floating.set(c, float) end + if geom then c:geometry(geom) end + if struts then c:struts(struts) end + + -- switch or highlight + local showtags = {} + local u = nil + if #target_tags > 0 and not startup then + for i,t in ipairs(target_tags) do + if not(awful.tag.getproperty(t,"nopopup") or nopopup) then + table.insert(showtags, t) + elseif not startup then + c.urgent = true + end + end + if #showtags > 0 then + local ident = true + for kk,vv in pairs(showtags) do + if sel[kk] ~= vv then ident = false; break end + end + if not ident then + awful.tag.viewmore(showtags, c.screen) + end + end + end + + -- focus and raise accordingly or lower if supressed + if not (nofocus or c.hidden or c.minimized) then + if (awful.tag.getproperty(target,"nopopup") or nopopup) and (target and target ~= sel) then + awful.client.focus.history.add(c) + else + client.focus = c + end + c:raise() + else + c:lower() + end + + -- execute run functions if specified + if #run > 0 then + for _, f in ipairs(run) do + f(c, startup, target) + end + end +end +--}}} + +--{{{ sweep : hook function that marks tags as used, visited, deserted +-- also handles deleting used and empty tags +function sweep() + for s = 1, screen.count() do + for i, t in ipairs(screen[s]:tags()) do + local clients = t:clients() + local sticky = 0 + for i, c in ipairs(clients) do + if c.sticky then sticky = sticky + 1 end + end + if #clients == sticky then + if not awful.tag.getproperty(t,"persist") and awful.tag.getproperty(t,"used") then + if awful.tag.getproperty(t,"deserted") or not awful.tag.getproperty(t,"leave_kills") then + local delay = awful.tag.getproperty(t,"sweep_delay") + if delay then + local f = function() del(t); tmr:stop() end + tmr = timer({ timeout = delay }) + tmr:connect_signal("timeout", f) + tmr:start() + else + del(t) + end + else + if not t.selected and awful.tag.getproperty(t,"visited") then awful.tag.setproperty(t,"deserted", true) end + end + end + else + awful.tag.setproperty(t,"used",true) + end + if t.selected then awful.tag.setproperty(t,"visited",true) end + end + end +end +--}}} + +--{{{ getpos : returns a tag to match position +-- * originally this function did a lot of client stuff, i think its +-- * better to leave what can be done by awful to be done by awful +-- * -perry +-- @param pos : the index to find +-- @return v : the tag (found or created) at position == 'pos' +function getpos(pos) + local v = nil + local existing = {} + local selected = nil + local scr = mouse.screen or 1 + -- search for existing tag assigned to pos + for i = 1, screen.count() do + local s = awful.util.cycle(screen.count(), scr + i - 1) + for j, t in ipairs(screen[s]:tags()) do + if awful.tag.getproperty(t,"position") == pos then + table.insert(existing, t) + if t.selected and s == scr then selected = #existing end + end + end + end + if #existing > 0 then + -- if makeing another of an existing tag, return the end of the list + if selected then v = existing[awful.util.cycle(#existing, selected + 1)] else v = existing[1] end + end + if not v then + -- search for preconf with 'pos' and create it + for i, j in pairs(config.tags) do + if j.position == pos then v = add({ name = i, position = pos, noswitch = not switch }) end + end + end + if not v then + -- not existing, not preconfigured + v = add({ position = pos, rename = pos .. ':', no_selectall = true, noswitch = not switch }) + end + return v +end +--}}} + +--{{{ init : search shifty.config.tags for initial set of tags to open +function init() + local numscr = screen.count() + + for i, j in pairs(config.tags) do + local scr = j.screen or 1 + if j.init and ( scr <= numscr ) then + add({ name = i, persist = true, screen = scr, layout = j.layout, mwfact = j.mwfact }) + end + end +end +--}}} + +--{{{ count : utility function returns the index of a table element +--FIXME: this is currently used only in remove_dup, so is it really necessary? +function count(table, element) + local v = 0 + for i, e in pairs(table) do + if element == e then v = v + 1 end + end + return v +end +--}}} + +--{{{ remove_dup : used by shifty.completion when more than one +--tag at a position exists +function remove_dup(table) + local v = {} + for i, entry in ipairs(table) do + if count(v, entry) == 0 then v[#v+ 1] = entry end + end + return v +end +--}}} + +--{{{ completion : prompt completion +-- +function completion(cmd, cur_pos, ncomp, sources, matchers) + + -- get sources and matches tables + sources = sources or config.prompt_sources + matchers = matchers or config.prompt_matchers + + local get_source = { + -- gather names from config.tags + config_tags = function() + local ret = {} + for n, p in pairs(config.tags) do table.insert(ret, n) end + return ret + end, + -- gather names from config.apps + config_apps = function() + local ret = {} + for i, p in pairs(config.apps) do + if p.tag then + if type(p.tag) == "string" then + table.insert(ret, p.tag) + else + ret = awful.util.table.join(ret, p.tag) + end + end + end + return ret + end, + -- gather names from existing tags, starting with the current screen + existing = function() + local ret = {} + for i = 1, screen.count() do + local s = awful.util.cycle(screen.count(), mouse.screen + i - 1) + local tags = screen[s]:tags() + for j, t in pairs(tags) do table.insert(ret, t.name) end + end + return ret + end, + -- gather names from history + history = function() + local ret = {} + local f = io.open(awful.util.getdir("cache") .. "/history_tags") + for name in f:lines() do table.insert(ret, name) end + f:close() + return ret + end, + } + + -- if empty, match all + if #cmd == 0 or cmd == " " then cmd = "" end + + -- match all up to the cursor if moved or no matchphrase + if matchp == "" or cmd:sub(cur_pos, cur_pos+#matchp) ~= matchp then + matchp = cmd:sub(1, cur_pos) + end + + -- find matching commands + local matches = {} + for i, src in ipairs(sources) do + local source = get_source[src]() + for j, matcher in ipairs(matchers) do + for k, name in ipairs(source) do + if name:find(matcher .. matchp) then + table.insert(matches, name) + end + end + end + end + + -- no matches + if #matches == 0 then return cmd, cur_pos end + + -- remove duplicates + matches = remove_dup(matches) + + -- cycle + while ncomp > #matches do ncomp = ncomp - #matches end + + -- put cursor at the end of the matched phrase + if #matches == 1 then + cur_pos = #matches[ncomp] + 1 + else + cur_pos = matches[ncomp]:find(matchp) + #matchp + end + + -- return match and position + return matches[ncomp], cur_pos +end +--}}} + +-- {{{ tagkeys : hook function that sets keybindings per tag +function tagkeys(s) + local sel = awful.tag.selected(s.index) + local keys = awful.tag.getproperty(sel, "keys") or config.globalkeys + if keys and sel.selected then root.keys(keys) end +end +-- }}} + +-- {{{ squash_keys: helper function which removes duplicate keybindings +-- by picking only the last one to be listed in keys table arg +function squash_keys(keys) + local squashed = {} + local ret = {} + for i, k in ipairs(keys) do + squashed[table.concat(k.modifiers) .. k.key] = k + end + for i, k in pairs(squashed) do + table.insert(ret, k) + end + return ret +end +-- }}} + +-- {{{ getlayout: returns a layout by name +function getlayout(name) + for _, layout in ipairs(config.layouts) do + if awful.layout.getname(layout) == name then return layout end + end +end +-- }}} + +-- {{{ signals +client.connect_signal("manage", match ) +client.connect_signal("unmanage", sweep) +client.disconnect_signal("manage", awful.tag.withcurrent) + +for s = 1, screen.count() do + awful.tag.attached_connect_signal(s, "property::selected", sweep) + awful.tag.attached_connect_signal(s, "tagged", sweep) + screen[s]:connect_signal("tag::history::update", tagkeys) +end + +for _,prop in ipairs { "visited", "initial", "matched", "used", "persist", "position" } do + ctag.add_signal("property::" .. prop) +end + +-- }}} + +-- vim: foldmethod=marker:filetype=lua:expandtab:shiftwidth=2:tabstop=2:softtabstop=2:encoding=utf-8:textwidth=80 diff --git a/awesomerc/rc-git/shiftyconfig.lua b/awesomerc/rc-git/shiftyconfig.lua new file mode 100644 index 0000000..8d8c565 --- /dev/null +++ b/awesomerc/rc-git/shiftyconfig.lua @@ -0,0 +1,107 @@ +-- Shifty configuration for Daniel's Awesome + +local awful = require 'awful' +local shifty = require 'shifty' +local beautiful = require 'beautiful' +local tjoin = awful.util.table.join +local reloader = require 'reloader' + +module(..., package.seeall) + +function go(modkey) + +shifty.config.tags = { + ["1:mail"] = { + init = true, + position = 1, + screen = 1, + mwfact = 0.60, + layout = awful.layout.suit.max, + }, + ["2:term"] = { + persist = true, + position = 2, + }, + ["3:www"] = { + --exclusive = true, + --max_clients = 1, + position = 3, + layout = awful.layout.suit.max, + }, + ["4:emacs"] = { + position = 4, + layout = awful.layout.suit.max, + }, + ["8:spotify"] = { + position = 8, + layout = awful.layout.suit.floating, + }, + ["9:vmware"] = { + position = 9, + layout = awful.layout.suit.max, + }, +} + +local function handle_placement(c, startup) + if not startup then + -- Put windows in a smart way, only if they does not set an initial position. + if not c.size_hints.user_position and not c.size_hints.program_position then + awful.placement.no_overlap(c) + awful.placement.no_offscreen(c) + end + else + -- We're doing startup management, which means we should ask our funky + -- restoration module if there's anything it can do for our client. + reloader.try_place_client(c) + end +end + +shifty.config.apps = { + { match = {"^Google%-chrome.*" }, + tag = "3:www", + }, + + { match = {"^Gnome%-terminal.*" }, + honorsizehints = false, + }, + + { match = { "^Mutt$", "^OfflineIMAP$" }, + tag = "1:mail", +-- props = { +-- maximized_horizontal = true, +-- maximized_vertical = true, +-- }, + }, + + { match = { "^Vmware$" }, + tag = "9:vmware", + }, + + { match = { "^Spotify$" }, + tag = "8:spotify", + }, + + { match = {"^Emacs$" }, + tag = "4:emacs", + honorsizehints = false, + }, + + { match = { "" }, + buttons = tjoin( + awful.button({ }, 1, function (c) client.focus = c; c:raise() end), + awful.button({ modkey }, 1, function (c) awful.mouse.client.move() end), + awful.button({ modkey }, 3, awful.mouse.client.resize ) + ), + border_width = beautiful.border_width, + border_color = beautiful.border_normal, + focus = true, + run = handle_placement, + }, +} + +shifty.config.defaults = { + layout = awful.layout.suit.floating, + run = function(tag) naughty.notify({ text = "New Tag: " .. tostring(tag.name) }) end, +} +end + diff --git a/default-dotfiles/config__awesome__rc.lua b/default-dotfiles/config__awesome__rc.lua new file mode 100644 index 0000000..63d9fa7 --- /dev/null +++ b/default-dotfiles/config__awesome__rc.lua @@ -0,0 +1,7 @@ +-- Find the rc-choose.lua of our resources + +local homec = os.getenv("HOME") .. "/.resources/awesomerc/" + +package.path = package.path .. ";" .. homec .. "/?.lua;" .. homec .. "/?/init.lua" + +require "rc-choose" diff --git a/default-dotfiles/emacs b/default-dotfiles/emacs new file mode 100644 index 0000000..405a699 --- /dev/null +++ b/default-dotfiles/emacs @@ -0,0 +1,2 @@ +(setq load-path (cons "~/.resources/emacs-lisp/" load-path)) +(require 'dot.emacs) diff --git a/default-dotfiles/gtkrc-2.0 b/default-dotfiles/gtkrc-2.0 new file mode 100644 index 0000000..7ae945d --- /dev/null +++ b/default-dotfiles/gtkrc-2.0 @@ -0,0 +1,10 @@ +style "default-style" +{ + GtkWindow::resize-grip-height = 0 + GtkWindow::resize-grip-width = 0 +} + +class "GtkWidget" style "default-style" + +gtk-icon-theme-name = "ubuntu-mono-dark" + diff --git a/default-dotfiles/mairixrc b/default-dotfiles/mairixrc new file mode 100644 index 0000000..2209a36 --- /dev/null +++ b/default-dotfiles/mairixrc @@ -0,0 +1,10 @@ +base=/home/dsilvers/Maildir + +maildir=MainMail...:PepperfishMail...:PepperfishAdmin...:CodethinkMail... +omit=PepperfishMail/SpamCaught:PepperfishAdmin/SpamCaught + +mformat=maildir + +mfolder=searchresults + +database=/home/dsilvers/.mutable-secrets/mairix.db diff --git a/default-dotfiles/muttrc b/default-dotfiles/muttrc new file mode 100644 index 0000000..b76665e --- /dev/null +++ b/default-dotfiles/muttrc @@ -0,0 +1 @@ +source "~/.resources/mutt/main.rc" diff --git a/default-dotfiles/offlineimaprc b/default-dotfiles/offlineimaprc new file mode 100644 index 0000000..5ad8cf7 --- /dev/null +++ b/default-dotfiles/offlineimaprc @@ -0,0 +1,140 @@ +[general] + +metadata = ~/.offlineimap + +accounts = MainMail,PepperfishMail,PepperfishAdmin,CodethinkMail + +maxsyncaccounts = 4 + +ui = blinkenlights + +#ui = Curses.Blinkenlights, TTY.TTYUI, +# Noninteractive.Basic, Noninteractive.Quiet + +ignore-readonly = no + +pythonfile = ~/.resources/offlineimap/extras.py + +[mbnames] + +# offlineimap can record your mailbox names in a format you specify. +# You can define the header, each mailbox item, the separator, +# and the footer. Here is an example for Mutt. +# If enabled is yes, all six setting must be specified, even if they +# are just the empty string "". +# +# The header, peritem, sep, and footer are all Python expressions passed +# through eval, so you can (and must) use Python quoting. + +enabled = yes +filename = ~/.resources/mutt/mailboxes.rc.oi +header = "# Mailboxes from OfflineIMAP\n\n" +peritem = mailboxes "=%(accountname)s/%(foldername)s" +sep = "\n" +footer = "\n\n# End\n" + +[ui.Curses.Blinkenlights] +# Character used to indicate thread status. + +statuschar = @ + +[Account MainMail] +localrepository = LocalMainMail +remoterepository = MainMail +autorefresh = 2 +quick = 4 +[Repository LocalMainMail] +type=Maildir +localfolders = ~/Maildir/MainMail +sep = / +restoreatime = 0 + +[Repository MainMail] +type = IMAP +remotehost = 10.112.102.1 +ssl = yes +remoteusereval = get_username("mainmail-secure.pepperfish.net") +remotepasseval = get_password("mainmail-secure.pepperfish.net") +maxconnections = 1 +holdconnectionopen = yes +nametrans = lambda foldername: re.sub(' ', '_', foldername) +foldersort = prioritycmp +folderfilter = lambda foldername: ("Archives" not in foldername) + +[Account PepperfishMail] +localrepository = LocalPepperfishMail +remoterepository = PepperfishMail +autorefresh = 2 +quick = 4 + +[Repository LocalPepperfishMail] +type=Maildir +localfolders = ~/Maildir/PepperfishMail +sep = / +restoreatime = no + +[Repository PepperfishMail] +type = IMAP +remotehost = 10.112.102.1 +ssl = yes +remoteusereval = get_username("pepperfishmail-secure.pepperfish.net") +remotepasseval = get_password("pepperfishmail-secure.pepperfish.net") +maxconnections = 1 +holdconnectionopen = yes +nametrans = lambda foldername: re.sub(' ', '_', foldername) +foldersort = prioritycmp + +[Account PepperfishAdmin] +localrepository = Ataraxia +remoterepository = PepperfishAdmin +autorefresh = 2 +quick = 4 + +[Repository Ataraxia] + +type = Maildir +localfolders = ~/Maildir/PepperfishAdmin +sep = / +restoreatime = no + +[Repository PepperfishAdmin] + +type = IMAP +remotehost = 10.112.102.1 +ssl = yes + +remoteusereval = get_username("pepperfishadmin-secure.pepperfish.net") +remotepasseval = get_password("pepperfishadmin-secure.pepperfish.net") + +maxconnections = 1 + +holdconnectionopen = yes +# keepalive = 60 + +nametrans = lambda foldername: re.sub(' ', '_', foldername) +foldersort = prioritycmp + +[Account CodethinkMail] +localrepository = LocalCodethinkMail +remoterepository = RemoteCodethinkMail +autorefresh = 2 +quick = 4 + +[Repository LocalCodethinkMail] +type = Maildir +localfolders = ~/Maildir/CodethinkMail +sep = / +restoreatime = no + +[Repository RemoteCodethinkMail] +type = IMAP +remotehost = mail.codethink.co.uk +remoteport = 994 +ssl = yes +remoteusereval = get_username("mail.codethink.co.uk") +remotepasseval = get_password("mail.codethink.co.uk") +maxconnections = 1 +holdconnectionopen = yes +nametrans = lambda foldername: re.sub(' ', '_', foldername) +foldersort = prioritycmp +folderfilter = lambda foldername: not("share.board.test" in foldername) diff --git a/default-dotfiles/vimrc b/default-dotfiles/vimrc new file mode 100644 index 0000000..d4ec9ee --- /dev/null +++ b/default-dotfiles/vimrc @@ -0,0 +1,5 @@ +set backupcopy=breakhardlink,auto +set bg=dark +syntax on +map! <F1> <Esc> + diff --git a/default-dotfiles/zshenv b/default-dotfiles/zshenv new file mode 100644 index 0000000..84cc576 --- /dev/null +++ b/default-dotfiles/zshenv @@ -0,0 +1,2 @@ +# Simply set up our completions path... +fpath=(~/.resources/zsh/complete $fpath) diff --git a/default-dotfiles/zshrc b/default-dotfiles/zshrc new file mode 100644 index 0000000..85a2764 --- /dev/null +++ b/default-dotfiles/zshrc @@ -0,0 +1,5 @@ +# -*- sh -*- + +# Load the ZSH configuration from resources + +source ~/.resources/zsh/rc diff --git a/emacs-lisp/custom-resources.el b/emacs-lisp/custom-resources.el new file mode 100644 index 0000000..90e7dd8 --- /dev/null +++ b/emacs-lisp/custom-resources.el @@ -0,0 +1,59 @@ +;;; Skeleton .emacs for installations + +(custom-set-variables + ;; custom-set-variables was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(auto-raise-tool-bar-buttons t t) + '(auto-resize-tool-bars t t) + '(battery-mode-line-format " [%b%p%% %t, %d°C]") + '(c-basic-offset 2) + '(c-comment-continuation-stars "* ") + '(c-default-style "daniel") + '(c-echo-syntactic-information-p t) + '(c-electric-pound-behavior (quote (alignleft))) + '(c-hanging-comment-ender-p nil) + '(c-hanging-comment-starter-p nil) + '(default-frame-alist (quote ((tool-bar-lines . 0) (menu-bar-lines . 0)))) + '(display-time-24hr-format t) + '(fill-column 79) + '(frame-background-mode (quote dark)) + '(gnuserv-frame (quote gnuserv-main-frame-function)) + '(indicate-empty-lines nil) + '(inhibit-startup-screen t) + '(jde-compile-option-depend t) + '(jde-compile-option-depend-switch (quote ("-depend"))) + '(mail-host-address "digital-scurf.org") + '(mode-line-inverse-video t) + '(p4-default-depot-completion-prefix "//") + '(paren-display-message (quote always)) + '(scroll-bar-mode nil) + '(tool-bar-button-margin 1 t) + '(tooltip-mode t nil (tooltip)) + '(tramp-default-method "ssh") + '(truncate-partial-width-windows nil) + '(vc-bzr-program "/usr/bin/bzr")) +(custom-set-faces + ;; custom-set-faces was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(default ((t (:stipple nil :background "Black" :foreground "White" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :height 160 :width normal :foundry "unknown" :family "Inconsolata")))) + '(bold ((t (:bold t)))) + '(cursor ((t (:background "Yellow")))) + '(font-lock-builtin-face ((((class color) (background dark)) (:foreground "SpringGreen")))) + '(font-lock-comment-face ((((class color) (background dark)) (:italic t :foreground "Green")))) + '(font-lock-constant-face ((((class color) (background dark)) (:bold t :foreground "Red")))) + '(font-lock-type-face ((((class color) (background dark)) (:bold t :foreground "LightBlue")))) + '(font-lock-variable-name-face ((((class color) (background dark)) (:bold t :foreground "MediumSlateBlue")))) + '(font-lock-warning-face ((((class color) (background dark)) (:bold t :foreground "Red")))) + '(mode-line ((t (:background "MidnightBlue" :foreground "Gold" :box (:line-width -1 :style released-button))))) + '(p4-diff-change-face ((t (:foreground "green")))) + '(p4-diff-file-face ((t (:background "gray20" :foreground "gold")))) + '(p4-diff-head-face ((t (:background "gray30" :foreground "midnight blue")))) + '(trailing-whitespace ((((class color) (background dark)) (:underline "white"))))) + +(setq debian-changelog-mailing-address "dsilvers@debian.org") +(put 'narrow-to-region 'disabled nil) + diff --git a/emacs-lisp/dot.emacs.el b/emacs-lisp/dot.emacs.el new file mode 100644 index 0000000..88a4aaa --- /dev/null +++ b/emacs-lisp/dot.emacs.el @@ -0,0 +1,101 @@ +;;; dot.emacs - a .emacs file in p-res +;; Copyright 2005 Daniel Silverstone + +(setq confirm-kill-emacs 'y-or-n-p) +(setq custom-file "~/.resources/emacs-lisp/custom-resources.el") + +(load "custom-resources") + +;;; Add all extra paths +(setq load-path (cons "~/.resources/emacs-lisp/modes" + (cons "~/.resources/emacs-lisp/general" + load-path)))) + +;;; Bring in configuration information + +(load "machine-settings") + +;; General settings (colours etc) + +(load "settings") + +;; Extra mode stuff +(load "load-modes") + +(require 'cmode-stuff) +(require 'perl-stuff) + +(require 'fill-column-indicator) + +(setq interpreter-mode-alist + (append '(("perl" . cperl-mode) + ("perl5" . cperl-mode) + ) + interpreter-mode-alist) + ) + +(setq auto-mode-alist + (append + '( + ("\\.1$" . nroff-mode) ; man pages end in numbers... + ("\\.2$" . nroff-mode) + ("\\.3$" . nroff-mode) + ("\\.4$" . nroff-mode) + ("\\.5$" . nroff-mode) + ("\\.6$" . nroff-mode) + ("\\.7$" . nroff-mode) + ("\\.8$" . nroff-mode) + ("\\.man$" . nroff-mode) ; or any of the following.. + ("\\.me$" . nroff-mode) + ("\\.mm$" . nroff-mode) + ("\\.mr$" . nroff-mode) + ("\\.ms$" . nroff-mode) + ("\\.p$" . pascal-mode) ; could be prolog, I suppose + ("\\.pas$" . pascal-mode) ; definately pascal. + ("\\.pfc$" . pascal-mode) ; Pascal-FC + ("\\.awk$" . awk-mode) + ("\\.pic$" . picture-mode) + ("\\.nl$" . prolog-mode) ; Yeah, sure.. Probably standard. + ("\\.tar$" . tar-mode) + ("\\.tgz$" . tar-mode) + ("\\.ps$" . postscript-mode) + ("\\.m$" . fundamental-mode) + ("\\.swift$" . swift-mode) + ("\\.Swift$" . swift-mode) + ("\\.SWIFT$" . swift-mode) + ("\\.latex$" . latex-mode) + ("\\.cls$" . latex-mode) + ("\\.\\([pP][Llm]\\|al\\)$" . cperl-mode) + ("/?[Mm]akefile" . makefile-mode) + ("\\.[Ss][qQ][lL]$" . plsql-mode) + ("\\.xs$" . c-mode) + ("\\.pod$" . cperl-mode) + ("\\.sty$" . latex-mode) + ("\\.java$" . java-mode-kludge) + ("\\.xml$" . xml-mode) + ("\\.dtd$" . dtd-mode) + ("\\.C$" . c++-mode) + ("\\.H$" . c++-mode) + ("\\.cxx" . c++-mode) + ("\\.cpp" . c++-mode) + ("\\.cc" . c++-mode) + ("\\.java$" . java-mode) + ("\\.php$" . sh-mode) + ("\\.tac$" . python-mode) + ("\\.md$" . markdown-mode) + ("\\.mdwn$" . markdown-mode) + ) + auto-mode-alist) + ) + + +(require 'project-local) + +(require 'linum) +(global-linum-mode t) + +(define-globalized-minor-mode global-fci-mode fci-mode (lambda () (fci-mode 1))) +(global-fci-mode 1) + +(provide 'dot.emacs) + diff --git a/emacs-lisp/dot.emacs.el.orig b/emacs-lisp/dot.emacs.el.orig new file mode 100644 index 0000000..f9783f8 --- /dev/null +++ b/emacs-lisp/dot.emacs.el.orig @@ -0,0 +1,99 @@ +;;; dot.emacs - a .emacs file in p-res +;; Copyright 2005 Daniel Silverstone + +(setq confirm-kill-emacs 'y-or-n-p) +(setq custom-file "~/.resources/emacs-lisp/custom-resources.el") + +(load "custom-resources") + +;;; Add all extra paths +(setq load-path (cons "~/.resources/emacs-lisp/modes" + (cons "~/.resources/emacs-lisp/general" + load-path)))) + +;;; Bring in configuration information + +(load "machine-settings") + +;; General settings (colours etc) + +(load "settings") + +;; Extra mode stuff +(load "load-modes") + +(require 'cmode-stuff) +(require 'perl-stuff) + +(require 'fill-column-indicator) + +(setq interpreter-mode-alist + (append '(("perl" . cperl-mode) + ("perl5" . cperl-mode) + ) + interpreter-mode-alist) + ) + +(setq auto-mode-alist + (append + '( + ("\\.1$" . nroff-mode) ; man pages end in numbers... + ("\\.2$" . nroff-mode) + ("\\.3$" . nroff-mode) + ("\\.4$" . nroff-mode) + ("\\.5$" . nroff-mode) + ("\\.6$" . nroff-mode) + ("\\.7$" . nroff-mode) + ("\\.8$" . nroff-mode) + ("\\.man$" . nroff-mode) ; or any of the following.. + ("\\.me$" . nroff-mode) + ("\\.mm$" . nroff-mode) + ("\\.mr$" . nroff-mode) + ("\\.ms$" . nroff-mode) + ("\\.p$" . pascal-mode) ; could be prolog, I suppose + ("\\.pas$" . pascal-mode) ; definately pascal. + ("\\.pfc$" . pascal-mode) ; Pascal-FC + ("\\.awk$" . awk-mode) + ("\\.pic$" . picture-mode) + ("\\.nl$" . prolog-mode) ; Yeah, sure.. Probably standard. + ("\\.tar$" . tar-mode) + ("\\.tgz$" . tar-mode) + ("\\.ps$" . postscript-mode) + ("\\.m$" . fundamental-mode) + ("\\.swift$" . swift-mode) + ("\\.Swift$" . swift-mode) + ("\\.SWIFT$" . swift-mode) + ("\\.latex$" . latex-mode) + ("\\.cls$" . latex-mode) + ("\\.\\([pP][Llm]\\|al\\)$" . cperl-mode) + ("/?[Mm]akefile" . makefile-mode) + ("\\.[Ss][qQ][lL]$" . plsql-mode) + ("\\.xs$" . c-mode) + ("\\.pod$" . cperl-mode) + ("\\.sty$" . latex-mode) + ("\\.java$" . java-mode-kludge) + ("\\.xml$" . xml-mode) + ("\\.dtd$" . dtd-mode) + ("\\.C$" . c++-mode) + ("\\.H$" . c++-mode) + ("\\.cxx" . c++-mode) + ("\\.cpp" . c++-mode) + ("\\.cc" . c++-mode) + ("\\.java$" . java-mode) + ("\\.php$" . sh-mode) + ("\\.tac$" . python-mode) + ) + auto-mode-alist) + ) + + +(require 'project-local) + +(require 'linum) +(global-linum-mode t) + +(define-globalized-minor-mode global-fci-mode fci-mode (lambda () (fci-mode 1))) +(global-fci-mode 1) + +(provide 'dot.emacs) + diff --git a/emacs-lisp/general/load-modes.el b/emacs-lisp/general/load-modes.el new file mode 100644 index 0000000..d26a398 --- /dev/null +++ b/emacs-lisp/general/load-modes.el @@ -0,0 +1,74 @@ +;;; Load Modes + +;; This loads in extra modes which we 'need' + +;; Perforce + +;(setenv "P4CONFIG" ".p4settings") +;(setq p4-use-p4config-exclusively t) +;(load-library "p4") +;(setq p4-use-p4config-exclusively t) + +;; pl/sql + +(load-library "plsql") + +;; mic-paren stuff +(load-library "mic-paren") +(paren-activate) +(custom-set-variables '(paren-display-message (quote always))) + +;; print key resets mode automatically +(defun interactive-set-auto-mode () "" + (interactive) + (set-auto-mode) +) + +(global-set-key [print] 'interactive-set-auto-mode) + +;; Lua mode stuff + +(load-library "lua") + +(setq auto-mode-alist (cons '("\\.lua$" . lua-mode) auto-mode-alist)) + +;; Vivek's nice HTMLify stuff + +(load-library "hfy") + +;; Bicycle repair man (Ask Lifeless and/or Sideshow Bob2) + +;; (autoload 'pymacs-load "pymacs" nil t) +;; (autoload 'pymacs-eval "pymacs" nil t) +;; (autoload 'pymacs-apply "pymacs") +;; (autoload 'pymacs-call "pymacs") + +;; (pymacs-load "bikeemacs" "brm-") +;;(brm-init) + +;; Useful little archy bits + +(defun dsilvers-insert-uuid () "" (interactive) +(insert (shell-command-to-string "uuidgen")) +) + +(defun dsilvers-insert-arch-tag () "" (interactive) +(insert "arch-tag: ") (dsilvers-insert-uuid) +) + +(global-set-key [(control c) (control a) t] 'dsilvers-insert-arch-tag) + +(defun dsilvers-id-to-fpr () "" (interactive) +(kill-region (point) (mark)) (insert + (shell-command-to-string (concat + "/home/dsilvers/bin/gpg-id-to-fpr " + (car kill-ring))))) + +(global-set-key [(control c) (control k) f] 'dsilvers-id-to-fpr) + + +(autoload 'vala-mode "vala-mode" "Major mode for editing Vala code." t) +(add-to-list 'auto-mode-alist '("\\.vala$" . vala-mode)) +(add-to-list 'auto-mode-alist '("\\.vapi$" . vala-mode)) +(add-to-list 'file-coding-system-alist '("\\.vala$" . utf-8)) +(add-to-list 'file-coding-system-alist '("\\.vapi$" . utf-8)) diff --git a/emacs-lisp/general/machine-settings.el b/emacs-lisp/general/machine-settings.el new file mode 100644 index 0000000..8dc5d53 --- /dev/null +++ b/emacs-lisp/general/machine-settings.el @@ -0,0 +1,71 @@ +(defun ms-assoc-regexp (alist item) +"Search `alist' for an element which, when run as a regexp, matches `item' + +An alist is of the form `((key . value)(key . value)....)' and as such, is +essentially a hash, although it's not efficient. + +assoc-regexp performs a scan for `item' in the keys of the alist, by +performing a regexp match against `item' for the keys as regexps. + +assoc-regexp returns the `value' stored against the first key which matches." + +(let (retvar) (progn + (while (and (not retvar) alist) + (if (string-match (car (car alist)) item) + (setq retvar (cdr (car alist)))) + (setq alist (cdr alist)) + ) ;; while + (identity retvar) ;; return the retvar value (nil if not found) +))) ;; defun assoc-regexp + +(defun ms-clean-shell-string (command) +"This cleans the ^J from the end of shell-command-to-string" +(substring (shell-command-to-string command) 0 -1)) + +(defun ms-get-host-parameters () +"Searches the environment, and uses such programs as uname, and hostname, to return host info. + +This function essentially determines the following, returning it as an alist. + Hostname, Domain name, System name, OS version, Hardware type and processor... + +E.g. the author's computer would return: + + ((\"hostname\" . \"ennui\") + (\"domainname\" . \"i.digital-scurf.org\") + (\"sysname\" . \"Linux\") + (\"osversion\" . \"2.2.16\") + (\"hardware\" . \"i586\") + (\"processor\" . \"unknown\")) +" +;; How do we do host/domain calculation? +(let (hostname-call-conventions-alist) (progn +(setq hostname-call-conventions-alist + '( + ("Linux" . "hostname") + ("BSD" . "hostname -s") + ("*" . "echo $HOSTNAME" ) ;; simple fallback incase all else fails + )) + +;; Try to obtain host, domain etc. + +(let (fulldetails systype) + (progn + (setq systype (ms-clean-shell-string "uname -s")) + (setq fulldetails (cons (cons "sysname" systype) fulldetails)) + (let (hosttemp) (progn + (setq hosttemp (ms-clean-shell-string + (ms-assoc-regexp hostname-call-conventions-alist systype) + )) + ;; By now, hosttemp is the short hostname, and (system-name) is the full name + (setq fulldetails (cons (cons "hostname" hosttemp) fulldetails)) + (setq hosttemp (substring (system-name) (1+ (length hosttemp)))) + (setq fulldetails (cons (cons "domainname" hosttemp) fulldetails)) + )) + ;; Finally, the rest can simply be obtained from uname's + (setq fulldetails (cons (cons "osversion" (ms-clean-shell-string "uname -r")) fulldetails)) + (setq fulldetails (cons (cons "hardware" (ms-clean-shell-string "uname -m")) fulldetails)) + (setq fulldetails (cons (cons "processor" (ms-clean-shell-string "uname -p")) fulldetails)) + +)) ; Outer let (with 'globals') +))); defun get-host-parameters + diff --git a/emacs-lisp/general/mic-paren.el b/emacs-lisp/general/mic-paren.el new file mode 100644 index 0000000..4e3859e --- /dev/null +++ b/emacs-lisp/general/mic-paren.el @@ -0,0 +1,1445 @@ +;;; mic-paren.el --- advanced highlighting of matching parentheses.
+
+;; Version: 3.7 - 2001-12-21
+;; Author: Mikael Sjödin (mic@docs.uu.se)
+;; Klaus Berndl <berndl@sdm.de>
+;; Keywords: languages, faces, parenthesis, matching
+;;
+;; Additional info:
+;; Copyright (C) 1997 Mikael Sjödin (mic@docs.uu.se)
+;; Maintenance and development (since v2.1): Klaus Berndl <berndl@sdm.de>
+;; Original author: Mikael Sjödin -- mic@docs.uu.se
+;; Additional code by: Vinicius Jose Latorre <vinicius@cpqd.br>
+;; Steven L Baur <steve@xemacs.org>
+;; Klaus Berndl <berndl@sdm.de>
+;;
+;; mic-paren.el is free software
+;;
+;; This file is *NOT* (yet?) part of GNU Emacs.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary
+
+;; ----------------------------------------------------------------------
+;; Short Description:
+;;
+;; Load this file, activate it and Emacs will display highlighting on
+;; whatever parenthesis (and paired delimiter if you like this) matches
+;; the one before or after point. This is an extension to the paren.el
+;; file distributed with Emacs. The default behaviour is similar to
+;; paren.el but more sophisticated. Normally you can try all default
+;; settings to enjoy mic-paren.
+;;
+;; Or - if you are a LaTeX writer like the current maintainer - try the
+;; following additional setup in your .emacs:
+;;
+;; ;; In LaTeX-mode we want this
+;; (add-hook 'LaTeX-mode-hook
+;; (function (lambda ()
+;; (paren-toggle-matching-quoted-paren 1)
+;; (paren-toggle-matching-paired-delimiter 1))))
+;;
+;; Or - if you are programming in C like languages - try also:
+;; (add-hook 'c-mode-common-hook
+;; (function (lambda ()
+;; (paren-toggle-open-paren-context 1))))
+;; ----------------------------------------------------------------------
+
+;; ----------------------------------------------------------------------
+;; Installation:
+;;
+;; o Place this file in a directory in your 'load-path and byte-compile
+;; it. You can surely ignore the warnings.
+;; o Put the following in your .emacs file:
+;; (GNU Emacs supports mic-paren only within a window-system but XEmacs
+;; supports mic-paren also without X)
+;; (when (or (string-match "XEmacs\\|Lucid" emacs-version) window-system)
+;; (require 'mic-paren) ; loading
+;; (paren-activate) ; activating
+;; ;;; set here any of the customizable variables of mic-paren:
+;; ;;; ...
+;; )
+;; o Restart your Emacs. mic-paren is now installed and activated!
+;; o To list the possible customizations enter `C-h f paren-activate' or
+;; go to the customization group `mic-paren-matching'.
+
+;; ----------------------------------------------------------------------
+;; Long Description:
+;;
+;; mic-paren.el is an extension and replacement to the packages paren.el
+;; and stig-paren.el for Emacs. When mic-paren is active Emacs normal
+;; parenthesis matching is deactivated. Instead parenthesis matching will
+;; be performed as soon as the cursor is positioned at a parenthesis. The
+;; matching parenthesis (or the entire expression between the
+;; parentheses) is highlighted until the cursor is moved away from the
+;; parenthesis. Features include:
+;; o Both forward and backward parenthesis matching (simultaneously if
+;; cursor is between two expressions).
+;; o Indication of mismatched parentheses.
+;; o Recognition of "escaped" (also often called "quoted") parentheses.
+;; o Option to match "escaped" parens too, especially in (La)TeX-mode
+;; (e.g. matches expressions like "\(foo bar\)" properly).
+;; o Offers two functions as replacement for forward-sexp and
+;; backward-sexp which handle properly quoted parens (s.a.). These new
+;; functions can automatically be bounded to the original binding of
+;; the standard forward-sexp and backward-sexp functions.
+;; o Option to activate matching of paired delimiter (i.e. characters with
+;; syntax '$'). This is useful for writing in LaTeX-mode for example.
+;; o Option to select in which situations (always, never, if match, if
+;; mismatch) the entire expression should be highlighted or only the
+;; matching parenthesis.
+;; o Message describing the match when the matching parenthesis is off-screen
+;; (vertical and/or horizontal). Message contains either the linenumber or
+;; the number of lines between the two matching parens. Option to select in
+;; which cases this message should be displayed.
+;; o Optional delayed highlighting (useful on slow systems),
+;; o Functions to activate/deactivate mic-paren.el are provided.
+;; o Numerous options to control the behaviour and appearance of
+;; mic-paren.el.
+;;
+;; mic-paren.el was originally developed and tested under Emacs 19.28 -
+;; 20.3. It should work on earlier and forthcoming Emacs versions. XEmacs
+;; compatibility has been provided by Steven L Baur <steve@xemacs.org>.
+;; Jan Dubois (jaduboi@ibm.net) provided help to get mic-paren to work in
+;; OS/2. Mic-paren versions >= v2.1 are only tested with recent Emacsen
+;; (FSF Emacs >= 20.3.1 and XEmacs >= 21.1) but should also work with
+;; earlier versions of (X)Emacs.
+;;
+;; This file can be obtained from "The EmacsWiki" and here from the
+;; packages-site: http://www.emacswiki.org/elisp/index.html
+
+;; ----------------------------------------------------------------------
+;; Available customizable options:
+;; - `paren-priority'
+;; - `paren-overlay-priority'
+;; - `paren-sexp-mode'
+;; - `paren-highlight-at-point'
+;; - `paren-highlight-offscreen'
+;; - `paren-display-message'
+;; - `paren-message-linefeed-display'
+;; - `paren-message-no-match'
+;; - `paren-message-show-linenumber'
+;; - `paren-message-truncate-lines'
+;; - `paren-ding-unmatched'
+;; - `paren-delay'
+;; - `paren-dont-touch-blink'
+;; - `paren-match-face'
+;; - `paren-mismatch-face'
+;; - `paren-no-match-paren'
+;; - `paren-bind-modified-sexp-functions'
+;; Available customizable faces:
+;; - `paren-face-match'
+;; - `paren-face-mismatch'
+;; - `paren-face-no-match'
+;; Available commands:
+;; - `paren-activate'
+;; - `paren-deactivate'
+;; - `paren-toggle-matching-paired-delimiter'
+;; - `paren-toggle-matching-quoted-paren'
+;; - `paren-toggle-open-paren-context'
+;; - `paren-forward-sexp'
+;; - `paren-backward-sexp'
+;; ----------------------------------------------------------------------
+
+;; IMPORTANT NOTES (important for people who have customized mic-paren
+;; from within elisp):
+;; - In version >= 3.3 the prefix "mic-" has been removed from the
+;; command-names 'mic-paren-forward-sexp' and 'mic-paren-backward-sexp'.
+;; Now all user-functions and -options begin with the prefix "paren-"
+;; because this package should be a replacement of the other
+;; paren-packages like paren.el and stig-paren.el!
+;; - In version >= 3.2 the prefix "mic-" has been removed from the
+;; command-names 'mic-paren-toggle-matching-quoted-paren' and
+;; 'mic-paren-toggle-matching-paired-delimiter'.
+;; - In versions >= 3.1 mic-paren is NOT auto. activated after loading.
+;; - In versions >= 3.0 the variable 'paren-face' has been renamed to
+;; `paren-match-face'.
+
+;; ----------------------------------------------------------------------
+;; Versions:
+;; v3.7 + Removed the message "You should be in LaTeX-mode!".
+;; + Fixed a bug in `paren-toggle-matching-quoted-paren'.
+;; + Fixed some misspellings in the comments and docs.
+;;
+;; v3.6 + Fixed a very small bug in `mic-paren-horizontal-pos-visible-p'.
+;; + The informational messages like "Matches ... [+28]" which are
+;; displayed if the matching paren is offscreen, do not longer
+;; wasting the log.
+;;
+;; v3.5 + No mic-paren-messages are displayed if we are in isearch-mode.
+;; + Matching quoted parens is switched on if entering a minibuffer.
+;; This is useful for easier inserting regexps, e.g. with
+;; `query-replace-regexp'. Now \(...\) will be highlighted in the
+;; minibuffer.
+;; + New option `paren-message-show-linenumber': You can determine the
+;; computation of the offscreen-message-linenumber: Either the
+;; number of lines between the two matching parens or the absolute
+;; linenumber (Thank you for the idea and a first implementation to
+;; Eliyahu Barzilay <eli@cs.bgu.ac.il>).
+;; + New option `paren-message-truncate-lines': If mic-paren messages
+;; should be truncated ot not (has only an effect in GNU Emacs 21).
+;; (Thank you for the idea and a first implementation to Eliyahu
+;; Barzilay <eli@cs.bgu.ac.il>).
+;;
+;; v3.4 + Corrected some bugs in the backward-compatibility for older
+;; Emacsen. Thanks to Tetsuo Tsukamoto <czkmt@remus.dti.ne.jp>.
+;;
+;; v3.3 + Now the priority of the paren-overlays can be customized
+;; (option `paren-overlay-priority'). For a description of the
+;; priority of an overlay see in the emacs-lisp-manual the node
+;; "Overlays". This option is mainly useful for experienced
+;; users which use many packages using overlays to perform their
+;; tasks.
+;; + Now you can determine what line-context will be displayed if
+;; the matching open paren is offscreen. In functional
+;; programming languages like lisp it is useful to display the
+;; following line in the echo-area if the opening matching paren
+;; has no preceding text in the same line.
+;; But in procedural languages like C++ or Java it is convenient
+;; to display the first previous non empty line in this case
+;; instead of the following line. Look at the new variable
+;; `paren-open-paren-context-backward' and the related toggling
+;; function `paren-toggle-open-paren-context' for a detailed
+;; description of this new feature.
+;; + In addition to the previous described new feature you can
+;; specify how a linefeed in the message (e.g. if the matching
+;; paren is offscreen) is displayed. This is mainly because the
+;; standard echo-area display of a linefeed (^J) is bad to read.
+;; Look at the option `paren-message-linefeed-display'.
+;; + Solved a little bug in the compatibility-code for Emacsen
+;; not supporting current customize-feature.
+;; + Removed the prefix "mic-" from the commands
+;; 'mic-paren-forward-sexp' and 'mic-paren-backward-sexp'. For
+;; an explanation look at comments for version v3.2.
+;;
+;; v3.2 + The prefix "mic-" has been removed from the commands
+;; 'mic-paren-toggle-matching-quoted-paren' and
+;; 'mic-paren-toggle-matching-paired-delimiter'. This is because
+;; of consistency. Now all user-variables, -faces and -commands
+;; begin with the prefix "paren-" and all internal functions and
+;; variables begin with the prefix "mic-paren-".
+;; + Now you can exactly specify in which situations the whole
+;; sexp should be highlighted (option `paren-sexp-mode'):
+;; Always, never, if match or if mismatch. Tested with Gnus
+;; Emacs >= 20.3.1 and XEmacs >= 21.1.
+;;
+;; v3.1 + From this version on mic-paren is not auto. loaded. To
+;; activate it you must call `paren-activate' (either in your
+;; .emacs or manually with M-x). Therefore the variable
+;; `paren-dont-activate-on-load' is obsolet and has been
+;; removed.
+;; + Now mic-paren works also in older Emacsen without the
+;; custom-feature. If the actual custom-library is provided
+;; mic-paren use them and is full customizable otherwise normal
+;; defvars are used for the options.
+;; + Fix of a bug displaying a message if the matching paren is
+;; horizontal out of view.
+;; + All new features are now tested with XEmacs >= 21.1.6
+;;
+;; v3.0 + Checking if matching paren is horizontally offscreen (in case
+;; of horizontal scrolling). In that case the message is
+;; displayed in the echo-area (anlogue to vertical offscreen).
+;; In case of horizontal offscreen closing parenthesis the
+;; displayed message is probably wider than the frame/window. So
+;; you can only read the whole message if you are using a
+;; package like mscroll.el (scrolling long messages) in GNU
+;; Emacs.
+;; + Now full customizable, means all user-options and -faces now
+;; can be set with the custom-feature of Emacs. On the other
+;; side this means this version of mic-paren only works with an
+;; Emacs which provides the custom-package!
+;; + In case of the matching paren is offscreen now the displayed
+;; message contains the linenumber of the matching paren too.
+;; This version is only tested with Gnu Emacs >= 20.4 and not with
+;; any XEmacs!
+;; Implemented by Klaus Berndl <berndl@sdm.de>
+;;
+;; v2.3 No additional feature but replacing 'char-bytes and
+;; 'char-before with 'mic-char-bytes and 'mic-char-before to
+;; prevent the global-namespace. Now the new features of v2.1
+;; and v2.2 are also tested with XEmacs!
+;;
+;; v2.2 Adding the new feature for matching paired delimiter. Not
+;; tested with XEmacs. Implemented by Klaus Berndl <berndl@sdm.de>
+;;
+;; v2.1 Adding the new feature for matching escaped parens too. Not
+;; tested with XEmacs. Implemented by Klaus Berndl <berndl@sdm.de>
+;;
+;; v2.0 Support for MULE and Emacs 20 multibyte characters added. Inspired
+;; by the suggestion and code of Saito Takaaki
+;; <takaaki@is.s.u-tokyo.ac.jp>
+;;
+;; v1.9 Avoids multiple messages/dings when point has not moved. Thus,
+;; mic-paren no longer overwrites messages in minibuffer. Inspired by
+;; the suggestion and code of Barzilay Eliyahu <eli@cs.bgu.ac.il>.
+;;
+;; v1.3.1 Some spelling corrected (from Vinicius Jose Latorre
+;; <vinicius@cpqd.br> and Steven L Baur <steve@xemacs.org>)
+;;
+;; v1.3 Added code from Vinicius Jose Latorre <vinicius@cpqd.br> to
+;; highlight unmatched parentheses (useful in minibuffer)
+;;
+;; v1.2.1 Fixed stuff to work with OS/2 emx-emacs
+;; - checks if x-display-colour-p is bound before calling it
+;; - changed how X/Lucid Emacs is detected
+;; Added automatic load of the timer-feature (+ variable to disable
+;; the loading)
+
+;; TODO:
+;;
+
+;;; Code
+
+(defvar mic-paren-version "3.7"
+ "Version string for mic-paren.")
+
+;;; ======================================================================
+;; Compatibility stuff
+;; BLOB to make custom stuff work even without customize
+(eval-and-compile
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+ (unless (fboundp 'defgroup)
+ (defmacro defgroup (&rest rest) nil))
+ (unless (fboundp 'defcustom)
+ (defmacro defcustom (sym val str &rest rest)
+ (` (defvar (, sym) (, val) (, str)))))
+ (unless (fboundp 'defface)
+ (defmacro defface (sym val str &rest rest)
+ (` (defvar (, sym) (make-face '(, sym)) (, str))))))
+
+
+;;; ======================================================================
+;;; here begin the user options
+
+(defgroup mic-paren-matching nil
+ "Showing advanced (un)matching of parens and expressions."
+ :prefix "paren-"
+ :group 'paren-matching)
+
+(defcustom paren-priority 'both
+ "*Defines the behaviour of mic-paren when point is between a
+closing and an opening parenthesis. This means what should be done in a
+situation like this: \(a b)\(c d)
+ ^
+ point
+- 'close means highlight the parenthesis matching the close-parenthesis
+ before the point \(highlight opening paren before 'a').
+- 'open means highlight the parenthesis matching the open-parenthesis after
+ the point \(highlight closing paren after 'd').
+- 'both means highlight both parenthesis matching the parenthesis beside
+ the point \(highlight opening before 'a' and closing after 'd')."
+ :type '(choice (const :tag "Match close" close)
+ (const :tag "Match open" open)
+ (const :tag "Match both" both))
+ :group 'mic-paren-matching)
+
+(defcustom paren-overlay-priority 999
+ "*Specify paren overlay priority \(Integer >= 0\). For a description of the
+priority of an overlay see in the emacs-lisp manual the node Overlays.
+Normally you don't want to change the default-value!"
+ :set (function
+ (lambda (symbol value)
+ (set symbol (if (< value 0) (* -1 value) value))))
+ :initialize 'custom-initialize-default
+ :type 'integer
+ :group 'mic-paren-matching)
+
+(defcustom paren-sexp-mode nil
+ "*Defines in which situations the whole sexp should be highlighted.
+This means the whole s-expression between the matching parenthesis is
+highlighted instead of only the matching/mismatching parenthesis.
+
+- t: Always highlight the whole s-expression.
+- nil: Never highlight the whole s-expression.
+- 'match: Highlight the whole s-expression only if the parens match.
+- 'mismatch: Highlight the whole s-expression only if the parens don't match."
+ :type '(choice (const :tag "Never sexp-mode" nil)
+ (const :tag "Always sexp-mode" t)
+ (const :tag "If match" match)
+ (const :tag "If mismatch" mismatch))
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-highlight-at-point t
+ "*If non-nil and point is after a close parenthesis, both the close
+and open parenthesis is highlighted. If nil, only the open parenthesis is
+highlighted."
+ :type '(choice (const :tag "Highlight both" t)
+ (const :tag "Highlight open" nil))
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-highlight-offscreen nil
+ "*If non-nil mic-paren will highlight text which is not visible in the
+current buffer.
+
+This is useful if you regularly display the current buffer in multiple
+windows or frames. For instance if you use follow-mode \(by
+andersl@csd.uu.se), however it may slow down your Emacs.
+
+\(This variable is ignored \(treated as non-nil) if you set paren-sexp-mode to
+non-nil.)"
+ :type 'boolean
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-display-message 'only
+ "*Display message if matching parenthesis is off-screen.
+Possible settings are:
+- 'always: message is always displayed regardless if offscreen or not
+- 'only: message is only displayed when matching is offscreen
+- 'never: never a message is displayed."
+ :type '(choice (const :tag "Display always" always)
+ (const :tag "Display if offscreen" only)
+ (const :tag "No Message display" never))
+ :group 'mic-paren-matching)
+
+(defcustom paren-message-linefeed-display " RET "
+ "*How a linefeed in the matching paren context message is displayed.
+There are three predefined values:
+- Displays linefeeds with \" RET \" in the message.
+- Displays linefeeds with a SPACE in the message.
+- Displays linefeeds in the standard-form, means with \"^J\".
+But you can also specify any user-defined string for it.
+
+For further explanations about message displaying look at
+`paren-display-message'."
+ :type '(choice (const :tag "Display with \"RET\"" :value " RET ")
+ (const :tag "Display with a SPACE" :value " ")
+ (const :tag "Standard" :value "^J")
+ (string :tag "User defined"))
+ :group 'mic-paren-matching)
+
+(defcustom paren-message-show-linenumber 'sexp
+ "*Determine the computation of the offscreen-message-linenumber.
+If the matching paren is offscreen, then maybe a message with the context of
+the matching paren and it´s linenumber is displayed \(depends on the setting
+in `paren-display-message'). Here the computation of the linenumber can be
+determined:
+- 'sexp: Display the number of lines between the matching parens. Then the
+ number of lines is displayed as negativ number if the matching paren
+ is somewhere above. Otherwise the number has a positive sign.
+- 'absolute: Display the absolute linenumber of the machting paren computed
+ from the beginning of the buffer."
+ :type '(choice (const :tag "Count accros sexp" sexp)
+ (const :tag "Absolute number" absolute))
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-message-no-match t
+ "*Display message if no matching parenthesis is found."
+ :type '(choice (const :tag "Display message" t)
+ (const :tag "No message" nil))
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-message-truncate-lines t
+ "*Non nil means truncate lines for all messages mic-paren can display.
+This option has only an effect with GNU Emacs 21.x!"
+ :type 'boolean
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-ding-unmatched nil
+ "*Non nil means make noise if the cursor is at an unmatched
+parenthesis or no matching parenthesis is found.
+Even if nil, typing an unmatched parenthesis produces a ding."
+ :type 'boolean
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-delay nil
+ "*This variable controls when highlighting is done.
+The variable has different meaning in different versions of Emacs.
+
+In Emacs 19.29 and below:
+ This variable is ignored.
+
+In Emacs 19.30:
+ A value of nil will make highlighting happen immediately \(this may slow
+ down your Emacs if running on a slow system). Any non-nil value will
+ delay highlighting for the time specified by post-command-idle-delay.
+
+In Emacs 19.31 and above:
+ A value of nil will make highlighting happen immediately \(this may slow
+ down your Emacs if running on a slow system). If not nil, the value
+ should be a number \(possible a floating point number if your Emacs
+ support floating point numbers). The number is the delay in seconds
+ before mic-paren performs highlighting.
+
+If you change this variable when mic-paren is active you have to
+re-activate \(with M-x paren-activate) mic-paren for the change to take
+effect."
+ :type '(choice (number :tag "Delay time")
+ (const :tag "No delay" nil))
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-dont-touch-blink nil
+ "*Non-nil means not to change the value of blink-matching-paren
+when mic-paren is activated of deactivated.
+If nil mic-paren turns of blinking when activated and turns on blinking when
+deactivated."
+ :type 'boolean
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-dont-load-timer (not (string-match "XEmacs\\|Lucid"
+ emacs-version))
+ "*If non-nil mic-paren will not try to load the timer-feature when
+loaded.
+
+\(I have no idea why Emacs user ever want to set this to non-nil but I hate
+packages which loads/activates stuff I don't want to use so I provide this
+way to prevent the loading if someone doesn't want timers to be loaded.)"
+ :type 'boolean
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-bind-modified-sexp-functions t
+ "*Automatic binding of the new sexp-functions to the old bindings.
+If non nil mic-paren checks at load-time the keybindings for the functions
+`forward-sexp' and `backward-sexp' and binds the modified sexp-functions
+`paren-forward-sexp' and `paren-backward-sexp' to exactly these
+bindings if and only if matching quoted/escaped parens is turned on by
+`paren-toggle-matching-quoted-paren'. These new binding is done only
+for the buffer local-key-map, therefore if you activate the quoted matching
+only in some modes from within a hook only in these buffers the new binding
+is active and 'in all other not.
+If you deactivate the quoted matching feature by
+`paren-toggle-matching-quoted-paren' then `forward-sexp' and
+`backward-sexp' will be bound again to their original key-bindings!"
+ :type 'boolean
+ :group 'mic-paren-matching)
+
+;;; ------------------------------
+;;; Faces
+;;; ------------------------------
+
+(defface paren-face-match
+ '((((class color)) (:background "turquoise"))
+ (t (:background "gray")))
+ "Mic-paren mode face used for a matching paren."
+ :group 'faces
+ :group 'mic-paren-matching)
+
+(defface paren-face-mismatch
+ '((((class color)) (:foreground "white" :background "purple"))
+ (t (:reverse-video t)))
+ "Mic-paren mode face used for a mismatching paren."
+ :group 'faces
+ :group 'mic-paren-matching)
+
+(defface paren-face-no-match
+ '((((class color)) (:foreground "black" :background "yellow"))
+ (t (:reverse-video t)))
+ "Mic-paren mode face used for an unmatched paren."
+ :group 'faces
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-match-face 'paren-face-match
+ "*Face to use for showing the matching parenthesis."
+ :type 'face
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-mismatch-face 'paren-face-mismatch
+ "*Face to use when highlighting a mismatched parenthesis."
+ :type 'face
+ :group 'mic-paren-matching)
+
+
+(defcustom paren-no-match-face 'paren-face-no-match
+ "*Face to use when highlighting an unmatched parenthesis."
+ :type 'face
+ :group 'mic-paren-matching)
+
+
+;;; End of User Options:
+;;; ======================================================================
+
+;;; Below there are only variables and options which either should be not
+;;; set directly but with toggle-functions or pure internal variables
+
+(defvar paren-match-quoted-paren nil
+ "*Non-nil causes to match properly quoted \(or escaped\) parens \(e.g. in
+TeX-files, e.g. \"\\\(x-3y + z = 7\\\)\"\). FSF-Emacs can not match quoted
+parens, so we must temporally deactivate the quoting until emacs has done
+its sexp-parsing. Therefore emacs itself does not \(can not!\) take into
+consideration if either both matched parens are quoted or none. But
+nevertheless we do this! Only symmetric balanced parens are matched: means
+either both matching parens must we quoted or none, otherwise they we will
+be highlighted as mismatched.
+This package offers also two slightly modified versions of forward-sexp
+\(resp. backward-sexp\):
+`paren-forward-sexp'\(`paren-backward-sexp'\). This versions can also
+jump to escaped/quoted parens.
+If this variable is not nil and `paren-bind-modified-sexp-functions' is set
+to non nil then `paren-toggle-matching-quoted-paren' will also toggle
+the original binding of `forward-sexp' \(resp. backward-sexp\) between the
+original functions and the modified equivalents.
+
+Do NOT set this variable directly but use
+`paren-toggle-matching-quoted-paren' to activate/deactivate/toggle this
+feature!. The best method is to do this in a mode hook, e.g.:
+\(add-hook \'LaTeX-mode-hook
+ \(function \(lambda \(\)
+ \(paren-toggle-matching-quoted-paren 1\)\)\)\)")
+
+(make-variable-buffer-local 'paren-match-quoted-paren)
+
+(defvar paren-match-paired-delimiter nil
+"*If not nil then characters with syntax '$' \(means paired delimiter\)
+will be matched if possible (e.g. in LaTeX \"$...$\" is equal with
+\"\\(...\\)\"\) . Unlike to parens quoted/escaped paired delimiter will
+never match.
+
+Do NOT set this variable directly but use
+`paren-toggle-matching-paired-delimiter' to activate/deactivate/toggle
+this feature!. The best method is to do this in a mode hook, e.g.:
+\(add-hook \'LaTeX-mode-hook
+ \(function \(lambda \(\)
+ \(paren-toggle-matching-paired-delimiter 1\)\)\)\)")
+
+(make-variable-buffer-local 'paren-match-paired-delimiter)
+
+(defvar paren-open-paren-context-backward nil
+"*Determines which context of the matching open paren will be displayed
+if the matching open paren is offscreen or `paren-display-message' is
+'always \(look at the documentation of `paren-display-message'\) and the
+matching open paren has no previous text in the same line.
+Meaning of the setting:
+- nil: Contents of the **next** not empty and not whitespace-line will be
+ displayed. This value is useful for example in functional programming
+ languages like \(emacs\)lisp.
+- not nil: Contents of the first **previous** not empty and not only
+ whitespace-line will be displayed. This value is useful for example in
+ procedural programming languages like C, C++, Java etc.
+
+Lets take a look at a short example:
+In languages like C++ we often have situations like
+ if \(i > VALUE\)
+ \{
+ // some code
+ \}
+With a value non nil the displayed opening-brace context would be
+\"if \(i > VALUE\)^J\{\" but with nil it would be \"\{^J // some code\"
+which would be in C++ lesser useful as the non nil version.
+\(The ^J stands for a newline in the buffer\).
+
+Do NOT set this variable directly but use `paren-toggle-open-paren-context'
+to change the value of this option!. The best method is to do this in a
+mode hook, e.g.:
+\(add-hook \'c-common-mode-hook
+ \(function \(lambda \(\)
+ \(paren-toggle-open-paren-context 1\)\)\)\)")
+
+(make-variable-buffer-local 'paren-open-paren-context-backward)
+
+(defconst mic-paren-original-keybinding-of-sexp-functions
+ (list (car (where-is-internal 'forward-sexp))
+ (car (where-is-internal 'backward-sexp))))
+
+
+;;; Compatibility.
+;;; Try to make mic-paren work in different Emacs flavours.
+
+;; XEmacs compatibility (mainly by Steven L Baur <steve@xemacs.org>)
+(eval-and-compile
+ (if (string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
+ (progn
+ (fset 'mic-make-overlay 'make-extent)
+ (fset 'mic-delete-overlay 'delete-extent)
+ (fset 'mic-overlay-put 'set-extent-property)
+ (defun mic-cancel-timer (timer) (delete-itimer timer))
+ (fset 'mic-run-with-idle-timer 'start-itimer)
+ )
+ (fset 'mic-make-overlay 'make-overlay)
+ (fset 'mic-delete-overlay 'delete-overlay)
+ (fset 'mic-overlay-put 'overlay-put)
+ (fset 'mic-cancel-timer 'cancel-timer)
+ (fset 'mic-run-with-idle-timer 'run-with-idle-timer)
+ ))
+
+;; MULE and Emacs 20 multibyte char compatibility.
+;; Implemented by defining dummys for functions which do not exist in vanilla
+;; Emacs.
+
+(if (fboundp 'char-bytes)
+ (fset 'mic-char-bytes 'char-bytes)
+ (defun mic-char-bytes (ch)
+ "Returns 1 for all input CH.
+Function defined by mic-paren to be compatible with multibyte Emacses."
+ 1))
+
+(if (fboundp 'char-before)
+ (fset 'mic-char-before 'char-before)
+ (defun mic-char-before (pos)
+ "Return character in current buffer preceding position POS.
+POS is an integer or a buffer pointer.
+If POS is out of range, the value is nil.
+Function defined by mic-paren to be compatible with multibyte Emacses."
+ (char-after (1- pos))))
+
+(defun mic-paren-nolog-message (&rest args)
+ "Works exactly like `message' but does not log the message"
+ (let ((msg (cond ((or (null args)
+ (null (car args)))
+ nil)
+ ((null (cdr args))
+ (car args))
+ (t
+ (apply 'format args)))))
+ ;; Now message is either nil or the formated string.
+ (if (fboundp 'display-message)
+ ;; XEmacs way of preventing log messages.
+ (if msg
+ (display-message 'no-log msg)
+ (clear-message 'no-log))
+ ;; Emacs way of preventing log messages.
+ (let ((message-log-max nil))
+ (if msg
+ (message "%s" msg)
+ (message nil))))
+ msg))
+
+
+;;; ======================================================================
+;;; User Functions:
+
+;;;###autoload
+(defun paren-activate ()
+ "Activates mic-paren parenthesis highlighting.
+paren-activate deactivates the paren.el and stig-paren.el packages if they are
+active !
+The following options are available via the customize-feature:
+ `paren-priority'
+ `paren-overlay-priority'
+ `paren-sexp-mode'
+ `paren-highlight-at-point'
+ `paren-highlight-offscreen'
+ `paren-display-message'
+ `paren-message-linefeed-display'
+ `paren-message-no-match'
+ `paren-message-show-linenumber'
+ `paren-message-truncate-lines'
+ `paren-ding-unmatched'
+ `paren-delay'
+ `paren-dont-touch-blink'
+ `paren-match-face'
+ `paren-mismatch-face'
+ `paren-no-match-face'
+ `paren-bind-modified-sexp-functions'
+The following options are settable via toggling functions \(look at the
+documentation of these options for the names of these functions\):
+ `paren-match-quoted-paren'
+ `paren-match-paired-delimiter'
+ `paren-open-paren-context-backward'"
+ (interactive)
+ ;; Deactivate mic-paren.el (To remove redundant hooks)
+ (paren-deactivate)
+ ;; Deactivate paren.el if loaded
+ (if (boundp 'post-command-idle-hook)
+ (remove-hook 'post-command-idle-hook 'show-paren-command-hook))
+ (remove-hook 'post-command-hook 'show-paren-command-hook)
+ (and (boundp 'show-paren-overlay)
+ show-paren-overlay
+ (mic-delete-overlay show-paren-overlay))
+ (and (boundp 'show-paren-overlay-1)
+ show-paren-overlay-1
+ (mic-delete-overlay show-paren-overlay-1))
+ ;; Deactivate stig-paren.el if loaded
+ (if (boundp 'post-command-idle-hook)
+ (remove-hook 'post-command-idle-hook 'stig-paren-command-hook))
+ (remove-hook 'post-command-hook 'stig-paren-command-hook)
+ (remove-hook 'post-command-hook 'stig-paren-safe-command-hook)
+ (remove-hook 'pre-command-hook 'stig-paren-delete-overlay)
+ ;; Deactivate Emacs standard parenthesis blinking
+ (or paren-dont-touch-blink
+ (setq blink-matching-paren nil))
+
+ (cond(
+ ;; If timers are available use them
+ ;; (Emacs 19.31 and above)
+ (featurep 'timer)
+ (if (numberp paren-delay)
+ (setq mic-paren-idle-timer
+ (mic-run-with-idle-timer paren-delay t
+ 'mic-paren-command-idle-hook))
+ (add-hook 'post-command-hook 'mic-paren-command-hook)))
+ ;; If the idle hook exists assume it is functioning and use it
+ ;; (Emacs 19.30)
+ ((and (boundp 'post-command-idle-hook)
+ (boundp 'post-command-idle-delay))
+ (if paren-delay
+ (add-hook 'post-command-idle-hook 'mic-paren-command-idle-hook)
+ (add-hook 'post-command-hook 'mic-paren-command-hook)))
+ ;; Check if we (at least) have a post-comand-hook, and use it
+ ;; (Emacs 19.29 and below)
+ ((boundp 'post-command-hook)
+ (add-hook 'post-command-hook 'mic-paren-command-hook))
+ ;; Not possible to install mic-paren hooks
+ (t (error "Cannot activate mic-paren in this Emacs version")))
+ ;; we want matching quoted parens is the minibuffer so easier inserting
+ ;; paren-expressions i a rexexp.
+ (add-hook 'minibuffer-setup-hook
+ 'mic-paren-minibuffer-setup-hook)
+ (add-hook 'minibuffer-exit-hook
+ 'mic-paren-minibuffer-exit-hook))
+
+
+
+;;;###autoload
+(defun paren-deactivate ()
+ "Deactivates mic-paren parenthesis highlighting"
+ (interactive)
+ ;; Deactivate (don't bother to check where/if mic-paren is acivte, just
+ ;; delete all possible hooks and timers)
+ (if (boundp 'post-command-idle-hook)
+ (remove-hook 'post-command-idle-hook 'mic-paren-command-idle-hook))
+ (if mic-paren-idle-timer
+ (mic-cancel-timer mic-paren-idle-timer))
+ (remove-hook 'post-command-hook 'mic-paren-command-hook)
+ (remove-hook 'minibuffer-setup-hook
+ 'mic-paren-minibuffer-setup-hook)
+ (remove-hook 'minibuffer-exit-hook
+ 'mic-paren-minibuffer-exit-hook)
+ ;; Remove any old highlighs
+ (mic-delete-overlay mic-paren-backw-overlay)
+ (mic-delete-overlay mic-paren-point-overlay)
+ (mic-delete-overlay mic-paren-forw-overlay)
+
+ ;; Reactivate Emacs standard parenthesis blinking
+ (or paren-dont-touch-blink
+ (setq blink-matching-paren t))
+ )
+
+;;;###autoload
+(defun paren-toggle-matching-paired-delimiter (arg &optional no-message)
+"Toggle matching paired delimiter, force on with positive arg. Use this in
+mode-hooks to activate or deactivate paired delimiter matching. If optional
+second argument NO-MESSAGE is not nil then no message is displayed about the
+current activation state of the paired-delimiter-matching feature."
+ (interactive "P")
+ (setq paren-match-paired-delimiter (if (numberp arg)
+ (> arg 0)
+ (not paren-match-paired-delimiter)))
+ (if (not no-message)
+ (message "Matching paired delimiter is %s"
+ (if paren-match-paired-delimiter
+ "ON."
+ "OFF."))))
+
+
+;;;###autoload
+(defun paren-toggle-matching-quoted-paren (arg &optional no-message)
+ "Toggle matching quoted parens, force on with positive arg. Use this in
+mode-hooks to activate or deactivate quoted paren matching. If optional second
+argument NO-MESSAGE is not nil then no message is displayed about the current
+activation state of the quoted-paren-matching feature."
+ (interactive "P")
+ (setq paren-match-quoted-paren (if (numberp arg)
+ (> arg 0)
+ (not paren-match-quoted-paren)))
+ ;; if matching quoted parens is active now bind the original binding of
+ ;; forward-sexp and backward-sexp to the modified
+ ;; versions paren-forward-sexp (resp. paren-backward-sexp)
+ ;; if not bind it back to the original forward-sexp (resp. backward-sexp).
+ (let ((key-forward-sexp (car
+ mic-paren-original-keybinding-of-sexp-functions))
+ (key-backward-sexp (car
+ (cdr
+ mic-paren-original-keybinding-of-sexp-functions))))
+ (if (and paren-bind-modified-sexp-functions
+ key-backward-sexp
+ key-forward-sexp)
+ (if paren-match-quoted-paren
+ (progn
+ (local-set-key key-forward-sexp
+ (quote paren-forward-sexp))
+ (local-set-key key-backward-sexp
+ (quote paren-backward-sexp)))
+ (local-set-key key-forward-sexp (quote forward-sexp))
+ (local-set-key key-backward-sexp (quote backward-sexp)))))
+ (if (not no-message)
+ (message "Matching quoted parens is %s"
+ (if paren-match-quoted-paren
+ "ON."
+ "OFF."))))
+
+;;;###autoload
+(defun paren-toggle-open-paren-context (arg)
+ "Toggle the determining of the context to display of the matching
+open-paren, force backward context with positive arg. Use this in mode-hooks.
+For a description of the meaning look at `paren-open-paren-context-backward'."
+ (interactive "P")
+ (setq paren-open-paren-context-backward
+ (if (numberp arg)
+ (> arg 0)
+ (not paren-open-paren-context-backward))))
+
+;;;###autoload
+(defun paren-forward-sexp (&optional arg)
+ "Acts like forward-sexp but can also handle quoted parens. Look at
+`paren-match-quoted-paren' for a detailed comment."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (let* ((uncharquote-diff (if (< arg 0) 2 1))
+ (match-check-diff (if (< arg 0) 1 2))
+ (charquote (mic-paren-uncharquote (- (point) uncharquote-diff)))
+ match-pos mismatch)
+ ;; we must encapsulate this in condition-case so we regain control
+ ;; after error and we can undo our unquoting if any done before!
+ (condition-case ()
+ (setq match-pos (scan-sexps (point) arg))
+ (error nil))
+ (mic-paren-recharquote charquote)
+ (if (not match-pos)
+ (buffer-end arg)
+ (setq mismatch (if charquote
+ (not (mic-paren-is-following-char-quoted
+ (- match-pos match-check-diff)))
+ (mic-paren-is-following-char-quoted
+ (- match-pos match-check-diff))))
+ (if (not mismatch)
+ (goto-char match-pos)
+ (forward-sexp arg)
+ ))))
+
+;;;###autoload
+(defun paren-backward-sexp (&optional arg)
+ "Acts like backward-sexp but can also matching quoted parens. Look at
+`paren-match-quoted-paren' for a detailed comment"
+ (interactive "p")
+ (or arg (setq arg 1))
+ (paren-forward-sexp (- arg)))
+
+
+;;; ======================================================================
+;;; Pure Internal variables:
+
+(defvar mic-paren-backw-overlay (mic-make-overlay (point-min) (point-min))
+ "Overlay for the open-paren which matches the close-paren before
+point. When in sexp-mode this is the overlay for the expression before point.")
+
+(defvar mic-paren-point-overlay (mic-make-overlay (point-min) (point-min))
+ "Overlay for the close-paren before point.
+\(Not used when is sexp-mode.)")
+
+(defvar mic-paren-forw-overlay (mic-make-overlay (point-min) (point-min))
+ "Overlay for the close-paren which matches the open-paren after
+point. When in sexp-mode this is the overlay for the expression after point.")
+
+(defvar mic-paren-idle-timer nil
+ "Idle-timer. Used only in Emacs 19.31 and above \(and if paren-delay is
+nil)")
+
+(defvar mic-paren-previous-location [nil nil nil]
+ "Records where point was the last time mic-paren performed some action.
+Format is [POINT BUFFER WINDOW]")
+
+
+;;; ======================================================================
+;;; Internal function:
+
+
+
+(defun mic-paren-command-hook ()
+ (or executing-kbd-macro
+ (input-pending-p) ;[This might cause trouble since the
+ ; function is unreliable]
+ (condition-case paren-error
+ (mic-paren-highlight)
+ (error
+ (if (not (window-minibuffer-p (selected-window)))
+ (message "mic-paren catched error (please report): %s"
+ paren-error))))))
+
+(defun mic-paren-command-idle-hook ()
+ (condition-case paren-error
+ (mic-paren-highlight)
+ (error
+ (if (not (window-minibuffer-p (selected-window)))
+ (message "mic-paren catched error (please report): %s"
+ paren-error)))))
+
+;; helper macro to set a FACE and the value of `paren-overlay-priority'
+;; to an OVERLAY.
+(defmacro mic-paren-overlay-set (overlay face)
+ (` (progn
+ (mic-overlay-put (, overlay)
+ 'face (, face))
+ (mic-overlay-put (, overlay)
+ 'priority paren-overlay-priority))))
+
+(defun mic-paren-minibuffer-setup-hook ()
+ (paren-toggle-matching-quoted-paren 1 t))
+
+(defun mic-paren-minibuffer-exit-hook ()
+ (paren-toggle-matching-quoted-paren -1 t))
+
+
+(defun mic-paren-highlight ()
+ "The main-function of mic-paren. Does all highlighting, dinging, messages,
+cleaning-up."
+ ;; Remove any old highlighting
+ (mic-delete-overlay mic-paren-forw-overlay)
+ (mic-delete-overlay mic-paren-point-overlay)
+ (mic-delete-overlay mic-paren-backw-overlay)
+
+ ;; Handle backward highlighting (when after a close-paren or a paired
+ ;; delimiter):
+ ;; If (positioned after a close-paren, and
+ ;; not before an open-paren when priority=open, and
+ ;; (paren-match-quoted-paren is t or the close-paren is not escaped))
+ ;; or
+ ;; (positioned after a paired delimiter, and
+ ;; not before a paired-delimiter when priority=open, and
+ ;; the paired-delimiter is not escaped))
+ ;; then
+ ;; perform highlighting
+ (if (or (and (eq (char-syntax (preceding-char)) ?\))
+ (not (and (eq (char-syntax (following-char)) ?\()
+ (eq paren-priority 'open)))
+ (or paren-match-quoted-paren
+ (not (mic-paren-is-following-char-quoted (- (point)
+ 2)))))
+ (and paren-match-paired-delimiter
+ (eq (char-syntax (preceding-char)) ?\$)
+ (not (and (eq (char-syntax (following-char)) ?\$)
+ (eq paren-priority 'open)))
+ (not (mic-paren-is-following-char-quoted (- (point) 2)))))
+ (let (open matched-paren charquote)
+ ;; if we want to match quoted parens we must change the syntax of
+ ;; the escape or quote-char temporarily. This will be undone later.
+ (setq charquote (mic-paren-uncharquote (- (point) 2)))
+ ;; Find the position for the open-paren
+ (save-excursion
+ (save-restriction
+ (if blink-matching-paren-distance
+ (narrow-to-region
+ (max (point-min)
+ (- (point) blink-matching-paren-distance))
+ (point-max)))
+ (condition-case ()
+ (setq open (scan-sexps (point) -1))
+ (error nil))))
+
+ ;; we must call matching-paren because scan-sexps don't care about
+ ;; the kind of paren (e.g. matches '( and '}). matching-paren only
+ ;; returns the character displaying the matching paren in buffer's
+ ;; syntax-table (regardless of the buffer's current contents!).
+ ;; Below we compare the results of scan-sexps and matching-paren
+ ;; and if different we display a mismatch.
+ (setq matched-paren (matching-paren (preceding-char)))
+ ;; matching-paren can only handle characters with syntax ) or (
+ (if (eq (char-syntax (preceding-char)) ?\$)
+ (setq matched-paren (preceding-char)))
+
+ ;; if we have changed the syntax of the escape or quote-char we
+ ;; must undo this and we can do this first now.
+ (mic-paren-recharquote charquote)
+
+ ;; If match found
+ ;; highlight expression and/or print messages
+ ;; else
+ ;; highlight unmatched paren
+ ;; print no-match message
+ (if open
+ (let ((mismatch (or (not matched-paren)
+ (/= matched-paren (char-after open))
+ (if charquote
+ (not (mic-paren-is-following-char-quoted
+ (1- open)))
+ (mic-paren-is-following-char-quoted
+ (1- open)))))
+ ;; check if match-pos is visible
+ (visible (and (pos-visible-in-window-p open)
+ (mic-paren-horizontal-pos-visible-p open))))
+ ;; If highlight is appropriate
+ ;; highlight
+ ;; else
+ ;; remove any old highlight
+ (if (or visible paren-highlight-offscreen paren-sexp-mode)
+ ;; If sexp-mode
+ ;; highlight sexp
+ ;; else
+ ;; highlight the two parens
+ (if (mic-paren-sexp-mode-p mismatch)
+ (progn
+ (setq mic-paren-backw-overlay
+ (mic-make-overlay open (point)))
+ (if mismatch
+ (mic-paren-overlay-set mic-paren-backw-overlay
+ paren-mismatch-face)
+ (mic-paren-overlay-set mic-paren-backw-overlay
+ paren-match-face)))
+ (setq mic-paren-backw-overlay
+ (mic-make-overlay
+ open
+ (+ open
+ (mic-char-bytes (char-after open)))))
+ (and paren-highlight-at-point
+ (setq mic-paren-point-overlay
+ (mic-make-overlay
+ (- (point)
+ (mic-char-bytes (preceding-char)))
+ (point))))
+ (if mismatch
+ (progn
+ (mic-paren-overlay-set mic-paren-backw-overlay
+ paren-mismatch-face)
+ (and paren-highlight-at-point
+ (mic-paren-overlay-set mic-paren-point-overlay
+ paren-mismatch-face)))
+ (mic-paren-overlay-set mic-paren-backw-overlay
+ paren-match-face)
+ (and paren-highlight-at-point
+ (mic-paren-overlay-set mic-paren-point-overlay
+ paren-match-face)))))
+ ;; Print messages if match is offscreen
+ (and (not (eq paren-display-message 'never))
+ (or (not visible) (eq paren-display-message 'always))
+ (not (window-minibuffer-p (selected-window)))
+ (not isearch-mode)
+ (mic-paren-is-new-location)
+ (let ((message-truncate-lines paren-message-truncate-lines))
+ (mic-paren-nolog-message "%s %s"
+ (if mismatch "MISMATCH:" "Matches")
+ (mic-paren-get-matching-open-text open))))
+ ;; Ding if mismatch
+ (and mismatch
+ paren-ding-unmatched
+ (mic-paren-is-new-location)
+ (ding)))
+ (setq mic-paren-backw-overlay
+ (mic-make-overlay (point)
+ (- (point)
+ (mic-char-bytes (preceding-char)))))
+ (mic-paren-overlay-set mic-paren-backw-overlay
+ paren-no-match-face)
+ (and paren-message-no-match
+ (not (window-minibuffer-p (selected-window)))
+ (not isearch-mode)
+ (mic-paren-is-new-location)
+ (mic-paren-nolog-message "No opening parenthesis found"))
+ (and paren-message-no-match
+ paren-ding-unmatched
+ (mic-paren-is-new-location)
+ (ding)))))
+
+ ;; Handle forward highlighting (when before an open-paren or a paired
+ ;; delimiter):
+ ;; If (positioned before an open-paren, and
+ ;; not after a close-paren when priority=close, and
+ ;; (paren-match-quoted-paren is t or the open-paren is not escaped))
+ ;; or
+ ;; (positioned before a paired delimiter, and
+ ;; not after a paired-delimiter when priority=close, and
+ ;; the paired-delimiter is not escaped))
+ ;; then
+ ;; perform highlighting
+ (if (or (and (eq (char-syntax (following-char)) ?\()
+ (not (and (eq (char-syntax (preceding-char)) ?\))
+ (eq paren-priority 'close)))
+ (or paren-match-quoted-paren
+ (not (mic-paren-is-following-char-quoted (1-
+ (point))))))
+ (and paren-match-paired-delimiter
+ (eq (char-syntax (following-char)) ?\$)
+ (not (and (eq (char-syntax (preceding-char)) ?\$)
+ (eq paren-priority 'close)))
+ (not (mic-paren-is-following-char-quoted (1- (point))))))
+ (let (close matched-paren charquote)
+ ;; if we want to match quoted parens we must change the syntax of
+ ;; the escape or quote-char temporarily. This will be undone later.
+ (setq charquote (mic-paren-uncharquote (1- (point))))
+ ;; Find the position for the close-paren
+ (save-excursion
+ (save-restriction
+ (if blink-matching-paren-distance
+ (narrow-to-region
+ (point-min)
+ (min (point-max)
+ (+ (point) blink-matching-paren-distance))))
+ (condition-case ()
+ (setq close (scan-sexps (point) 1))
+ (error nil))))
+
+ ;; for an explanation look above.
+ (setq matched-paren (matching-paren (following-char)))
+ (if (eq (char-syntax (following-char)) ?\$)
+ (setq matched-paren (following-char)))
+
+ ;; if we have changed the syntax of the escape or quote-char we
+ ;; must undo this and we can do this first now.
+ (mic-paren-recharquote charquote)
+
+ ;; If match found
+ ;; highlight expression and/or print messages
+ ;; else
+ ;; highlight unmatched paren
+ ;; print no-match message
+ (if close
+ (let ((mismatch (or (not matched-paren)
+ (/= matched-paren (mic-char-before close))
+ (if charquote
+ (not (mic-paren-is-following-char-quoted
+ (- close 2)))
+ (mic-paren-is-following-char-quoted
+ (- close 2)))))
+ ;; check if match-pos is visible
+ (visible (and (pos-visible-in-window-p close)
+ (mic-paren-horizontal-pos-visible-p close))))
+ ;; If highlight is appropriate
+ ;; highlight
+ ;; else
+ ;; remove any old highlight
+ (if (or visible paren-highlight-offscreen paren-sexp-mode)
+ ;; If sexp-mode
+ ;; highlight sexp
+ ;; else
+ ;; highlight the two parens
+ (if (mic-paren-sexp-mode-p mismatch)
+ (progn
+ (setq mic-paren-forw-overlay
+ (mic-make-overlay (point) close))
+ (if mismatch
+ (mic-paren-overlay-set mic-paren-forw-overlay
+ paren-mismatch-face)
+ (mic-paren-overlay-set mic-paren-forw-overlay
+ paren-match-face)))
+ (setq mic-paren-forw-overlay
+ (mic-make-overlay
+ (- close
+ (mic-char-bytes (mic-char-before close)))
+ close))
+ (if mismatch
+ (mic-paren-overlay-set mic-paren-forw-overlay
+ paren-mismatch-face)
+ (mic-paren-overlay-set mic-paren-forw-overlay
+ paren-match-face))))
+
+ ;; Print messages if match is offscreen
+ (and (not (eq paren-display-message 'never))
+ (or (not visible) (eq paren-display-message 'always))
+ (not (window-minibuffer-p (selected-window)))
+ (not isearch-mode)
+ (mic-paren-is-new-location)
+ (let ((message-truncate-lines paren-message-truncate-lines))
+ (mic-paren-nolog-message "%s %s"
+ (if mismatch "MISMATCH:" "Matches")
+ (mic-paren-get-matching-close-text close))))
+ ;; Ding if mismatch
+ (and mismatch
+ (mic-paren-is-new-location)
+ paren-ding-unmatched
+ (ding)))
+ (setq mic-paren-forw-overlay
+ (mic-make-overlay (point)
+ (+ (point)
+ (mic-char-bytes (following-char)))))
+ (mic-paren-overlay-set mic-paren-forw-overlay
+ paren-no-match-face)
+ (and paren-message-no-match
+ (not (window-minibuffer-p (selected-window)))
+ (not isearch-mode)
+ (mic-paren-is-new-location)
+ (mic-paren-nolog-message "No closing parenthesis found"))
+ (and paren-message-no-match
+ paren-ding-unmatched
+ (mic-paren-is-new-location)
+ (ding)))))
+
+ ;; Store the points position in mic-paren-previous-location
+ ;; Later used by mic-paren-is-new-location
+ (or (window-minibuffer-p (selected-window))
+ (progn
+ (aset mic-paren-previous-location 0 (point))
+ (aset mic-paren-previous-location 1 (current-buffer))
+ (aset mic-paren-previous-location 2 (selected-window))))
+ )
+
+;;; --------------------------------------------------
+
+(defun mic-paren-sexp-mode-p (mismatch)
+ "Check if we must highlight the whole sexp and return t if we must"
+ (cond ((eq paren-sexp-mode nil) nil)
+ ((eq paren-sexp-mode t) t)
+ ((eq paren-sexp-mode 'match) (not mismatch))
+ ((eq paren-sexp-mode 'mismatch) mismatch)))
+
+;;; --------------------------------------------------
+
+(defun mic-paren-horizontal-pos-visible-p (match-pos)
+ "Returns non nil if the MATCH-POS is horizontal visible otherwise nil \(in
+case of horizontal scrolling)."
+ (let ((window (selected-window)))
+ (save-excursion
+ (goto-char match-pos)
+ (and (>= (- (current-column) (window-hscroll window)) 0)
+ (< (- (current-column) (window-hscroll window))
+ (window-width window))))))
+
+;; (defun mic-paren-horizontal-pos-visible-p (match-pos)
+;; "Returns non nil if the MATCH-POS is horizontal visible otherwise nil \(in
+;; case of horizontal scrolling)."
+;; (let ((match-column
+;; (save-excursion
+;; (goto-char match-pos)
+;; (current-column))))
+;; (if (> (window-hscroll) 0)
+;; (and (>= match-column (window-hscroll))
+;; (< match-column (+ (window-hscroll) (window-width))))
+;; (< match-column (window-width)))))
+
+(defun mic-paren-get-matching-open-text (open)
+ "Returns a string with the context around OPEN-paren."
+ ;; If there's stuff on this line preceding the paren, then display text from
+ ;; beginning of line to paren.
+ ;;
+ ;; If, however, the paren is at the beginning of a line (means only
+ ;; whitespace before the paren), then skip whitespace forward and display
+ ;; text from paren to end of the next line containing non-space text. But
+ ;; if `paren-open-paren-context-backward' is non nil then skip
+ ;; whitespaces backward and display text from beginning of previous line
+ ;; to paren.
+ (let* ((loc (if (eq paren-message-show-linenumber 'sexp)
+ (point) (point-min)))
+ (str (save-excursion
+ (goto-char open)
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (not (bolp)))
+ (progn
+ (beginning-of-line)
+ (format "%s... [%s%d-]"
+ (buffer-substring (point) (1+ open))
+ (if (eq paren-message-show-linenumber 'sexp)
+ "-" "")
+ (count-lines loc open)))
+ (let (paren-context-string)
+ (if (not paren-open-paren-context-backward)
+ (progn
+ (forward-char 1)
+ (skip-chars-forward "\n \t")
+ (end-of-line)
+ (setq paren-context-string (buffer-substring open (point))))
+ (skip-chars-backward "\n \t")
+ (beginning-of-line)
+ (setq paren-context-string (buffer-substring (point) (1+ open))))
+ (format "%s [%s%d]"
+ paren-context-string
+ (if (eq paren-message-show-linenumber 'sexp)
+ "-" "")
+ (count-lines loc open)))))))
+ (while (string-match "[\n]" str)
+ (setq str (replace-match paren-message-linefeed-display nil t str)))
+ str))
+
+
+
+(defun mic-paren-get-matching-close-text (close)
+ "Returns a string with the context around CLOSE-paren."
+ ;; The whole line up until the close-paren with "..." appended if there are
+ ;; more text after the close-paren
+ (let* ((loc (if (eq paren-message-show-linenumber 'sexp)
+ (point) (point-min)))
+ (str (save-excursion
+ (goto-char close)
+ (forward-char -1)
+ (skip-chars-backward "\n \t")
+ (beginning-of-line)
+ (format "%s%s [%s%d]"
+ (buffer-substring (point) close)
+ (progn
+ (goto-char close)
+ (if (looking-at "[ \t]*$")
+ ""
+ "..."))
+ (if (eq paren-message-show-linenumber 'sexp)
+ "+" "")
+ (count-lines loc close)))))
+ (while (string-match "[\n]" str)
+ (setq str (replace-match paren-message-linefeed-display nil t str)))
+ str))
+
+
+
+(defun mic-paren-is-new-location ()
+ "Returns t if the points location is not the same as stored in
+`mic-paren-previous-location', nil otherwise.
+
+The variable `mic-paren-previous-location' is set by
+`mic-paren-highlight'."
+ (not (and (eq (point) (aref mic-paren-previous-location 0))
+ (eq (current-buffer) (aref mic-paren-previous-location 1))
+ (eq (selected-window) (aref mic-paren-previous-location 2)))))
+
+
+(defun mic-paren-is-following-char-quoted (pnt)
+ "returns true if character at point PNT escapes or quotes the following
+char."
+ (let ((n 0))
+ (while (and (>= pnt (point-min))
+ (or (eq (char-syntax (char-after pnt)) ?\\)
+ (eq (char-syntax (char-after pnt)) ?/)))
+ (setq n (1+ n))
+ (setq pnt (1- pnt)))
+ (if (eq 0 (% n 2)) nil t)))
+
+(defun mic-paren-uncharquote (pnt)
+ "if the syntax of character <c> at point PNT is escape or quote and if the
+character is not escaped or quoted itself then its syntax will be modified
+to punctuation and multiple values \(<c> \"<syntax-of-c>\") will be returned;
+otherwise nil."
+ (let (c cs)
+ (if (< pnt (point-min))
+ nil
+ (setq c (char-after pnt))
+ (setq cs (char-syntax c))
+ (if (not (and paren-match-quoted-paren
+ (mic-paren-is-following-char-quoted pnt)))
+ nil
+ (modify-syntax-entry c ".")
+ (list c (char-to-string cs))))))
+
+(defun mic-paren-recharquote (charquote)
+ "CHARQUOTE is a 2-element-list: car is a character <c> and its cadr
+is a syntaxstring <s>. The syntax of character <c> will be set to syntax
+<s>. If CHARQUOTE is nil nothing will be done."
+ (if charquote
+ (modify-syntax-entry (car charquote) (car (cdr charquote)))))
+
+
+;;; ======================================================================
+;;; Initialisation when loading:
+
+;;; Try to load the timer feature if its not already loaded
+(or paren-dont-load-timer
+ (featurep 'timer)
+ (condition-case ()
+ (require 'timer)
+ (error nil)))
+
+(provide 'mic-paren)
+(provide 'paren)
+
+;;; mic-paren.el ends here
diff --git a/emacs-lisp/general/project-local.el b/emacs-lisp/general/project-local.el new file mode 100644 index 0000000..c68bd57 --- /dev/null +++ b/emacs-lisp/general/project-local.el @@ -0,0 +1,30 @@ +;;; Project-Local settings. +;;; Copyright 2008 Daniel Silverstone <dsilvers@digital-scurf.org> + +(provide 'project-local) +(require 'time-date) + +(defvar plocal-project-file ".project-locals.el" + "Name for project-local files. +Emacs will look up the directory tree for a project-local file of settings. +It will then be loaded during the find-file-hook.") + +(setq plocal-file-hash (make-hash-table :test 'equal)) + +(defun plocal-find-project-file (dir) + (let ((f (expand-file-name plocal-project-file dir)) + (parent (file-truename (expand-file-name ".." dir)))) + (cond ((string= dir parent) nil) + ((file-exists-p f) f) + (t (plocal-find-project-file parent))))) + +(defun plocal-eval-project-file () + (let* ((pfile (plocal-find-project-file default-directory)) + (pfilemod (cond (pfile (nth 5 (file-attributes pfile))))) + (pfilehashmod (gethash pfile plocal-file-hash))) + (when (and pfile (or (null pfilehashmod) (time-less-p pfilehashmod pfilemod))) + (load pfile) + (puthash pfile pfilemod plocal-file-hash)))) + +(add-hook 'find-file-hook 'plocal-eval-project-file) + diff --git a/emacs-lisp/general/redo.el b/emacs-lisp/general/redo.el new file mode 100644 index 0000000..3022838 --- /dev/null +++ b/emacs-lisp/general/redo.el @@ -0,0 +1,189 @@ +;;; redo.el -- Redo/undo system for XEmacs + +;; Copyright (C) 1985, 1986, 1987, 1993-1995 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1997 Kyle E. Jones + +;; Author: Kyle E. Jones, February 1997 +;; Keywords: lisp, extensions + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; Derived partly from lisp/prim/simple.el in XEmacs. + +;; Emacs' normal undo system allows you to undo an arbitrary +;; number of buffer changes. These undos are recorded as ordinary +;; buffer changes themselves. So when you break the chain of +;; undos by issuing some other command, you can then undo all +;; the undos. The chain of recorded buffer modifications +;; therefore grows without bound, truncated only at garbage +;; collection time. +;; +;; The redo/undo system is different in two ways: +;; 1. The undo/redo command chain is only broken by a buffer +;; modification. You can move around the buffer or switch +;; buffers and still come back and do more undos or redos. +;; 2. The `redo' command rescinds the most recent undo without +;; recording the change as a _new_ buffer change. It +;; completely reverses the effect of the undo, which +;; includes making the chain of buffer modification records +;; shorter by one, to counteract the effect of the undo +;; command making the record list longer by one. +;; +;; Installation: +;; +;; Save this file as redo.el, byte compile it and put the +;; resulting redo.elc file in a directory that is listed in +;; load-path. +;; +;; In your .emacs file, add +;; (require 'redo) +;; and the system will be enabled. + +;;; Code: + +(provide 'redo) + +(defvar redo-version "1.01" + "Version number for the Redo package.") + +(defvar last-buffer-undo-list nil + "The head of buffer-undo-list at the last time an undo or redo was done.") +(make-variable-buffer-local 'last-buffer-undo-list) + +(make-variable-buffer-local 'pending-undo-list) + +(defun redo (&optional count) + "Redo the the most recent undo. +Prefix arg COUNT means redo the COUNT most recent undos. +If you have modified the buffer since the last redo or undo, +then you cannot redo any undos before then." + (interactive "*p") + (if (eq buffer-undo-list t) + (error "No undo information in this buffer")) + (if (eq last-buffer-undo-list nil) + (error "No undos to redo")) + (or (eq last-buffer-undo-list buffer-undo-list) + (and (null (car-safe buffer-undo-list)) + (eq last-buffer-undo-list (cdr-safe buffer-undo-list))) + (error "Buffer modified since last undo/redo, cannot redo")) + (and (or (eq buffer-undo-list pending-undo-list) + (eq (cdr buffer-undo-list) pending-undo-list)) + (error "No further undos to redo in this buffer")) + (or (eq (selected-window) (minibuffer-window)) + (message "Redo...")) + (let ((modified (buffer-modified-p)) + (recent-save (recent-auto-save-p)) + (old-undo-list buffer-undo-list) + (p (cdr buffer-undo-list)) + (records-between 0)) + ;; count the number of undo records between the head of the + ;; undo chain and the pointer to the next change. Note that + ;; by `record' we mean clumps of change records, not the + ;; boundary records. The number of records will always be a + ;; multiple of 2, because an undo moves the pending pointer + ;; forward one record and prepend a record to the head of the + ;; chain. Thus the separation always increases by two. WHen + ;; we decrease it we will decrease it by a multiple of 2 + ;; also. + (while p + (cond ((eq p pending-undo-list) + (setq p nil)) + ((null (car p)) + (setq records-between (1+ records-between)) + (setq p (cdr p))) + (t + (setq p (cdr p))))) + ;; we're off by one if pending pointer is nil, because there + ;; was no boundary record in front of it to count. + (and (null pending-undo-list) + (setq records-between (1+ records-between))) + ;; don't allow the user to redo more undos than exist. + ;; only half the records between the list head and the pending + ;; pointer are undos that are a part of this command chain. + (setq count (min (/ records-between 2) count) + p (primitive-undo (1+ count) buffer-undo-list)) + (if (eq p old-undo-list) + nil ;; nothing happened + ;; set buffer-undo-list to the new undo list. if has been + ;; shortened by `count' records. + (setq buffer-undo-list p) + ;; primitive-undo returns a list without a leading undo + ;; boundary. add one. + (undo-boundary) + ;; now move the pending pointer backward in the undo list + ;; to reflect the redo. sure would be nice if this list + ;; were doubly linked, but no... so we have to run down the + ;; list from the head and stop at the right place. + (let ((n (- records-between count))) + (setq p (cdr old-undo-list)) + (while (and p (> n 0)) + (if (null (car p)) + (setq n (1- n))) + (setq p (cdr p))) + (setq pending-undo-list p))) + (and modified (not (buffer-modified-p)) + (delete-auto-save-file-if-necessary recent-save)) + (or (eq (selected-window) (minibuffer-window)) + (message "Redo!")) + (setq last-buffer-undo-list buffer-undo-list))) + +(defun undo (&optional arg) + "Undo some previous changes. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count." + (interactive "*p") + (let ((modified (buffer-modified-p)) + (recent-save (recent-auto-save-p))) + (or (eq (selected-window) (minibuffer-window)) + (message "Undo...")) + (or (eq last-buffer-undo-list buffer-undo-list) + (and (null (car-safe buffer-undo-list)) + (eq last-buffer-undo-list (cdr-safe buffer-undo-list))) + (progn (undo-start) + (undo-more 1))) + (undo-more (or arg 1)) + ;; Don't specify a position in the undo record for the undo command. + ;; Instead, undoing this should move point to where the change is. + ;; + ;;;; The old code for this was mad! It deleted all set-point + ;;;; references to the position from the whole undo list, + ;;;; instead of just the cells from the beginning to the next + ;;;; undo boundary. This does what I think the other code + ;;;; meant to do. + (let ((list buffer-undo-list) + (prev nil)) + (while (and list (not (null (car list)))) + (if (integerp (car list)) + (if prev + (setcdr prev (cdr list)) + ;; impossible now, but maybe not in the future + (setq buffer-undo-list (cdr list)))) + (setq prev list + list (cdr list)))) + (and modified (not (buffer-modified-p)) + (delete-auto-save-file-if-necessary recent-save))) + (or (eq (selected-window) (minibuffer-window)) + (message "Undo!")) + (setq last-buffer-undo-list buffer-undo-list)) + +;;; redo.el ends here diff --git a/emacs-lisp/general/rfc1345.el b/emacs-lisp/general/rfc1345.el Binary files differnew file mode 100644 index 0000000..87c62b2 --- /dev/null +++ b/emacs-lisp/general/rfc1345.el diff --git a/emacs-lisp/general/settings.el b/emacs-lisp/general/settings.el new file mode 100644 index 0000000..cfabd60 --- /dev/null +++ b/emacs-lisp/general/settings.el @@ -0,0 +1,42 @@ +;;; emacs-lisp/general/settings.el + +;; General gumpf +(global-font-lock-mode t) + +(setq frame-title-format "EMACS - An operation system disguised as a text editor") + +;; Load time display + +(global-set-key [home] 'beginning-of-buffer) +(global-set-key [end] 'end-of-buffer) + +;; And a font + +;; Finally a useful function + +(defun kill-buffer-verbosely (arg) + "Applies 'kill-buffer' to 'arg' reporting so in the minibuffer." + (interactive "b") + (let ((name (buffer-name arg))) + (message (concat "Killing " name "...")) + (kill-buffer arg) + (message (concat "Killing " name "...Done")) +)) + +(defun kill-all-buffers () + "Applies 'kill-buffer' to all buffers in 'buffer-list'" + (interactive) + (mapcar 'kill-buffer (buffer-list))) + +;; And map it to a key... + +(global-set-key "\C-x\M-x" 'kill-all-buffers) + +(require 'redo) +(global-set-key "\M-_" 'redo) + +(setq scroll-step 1) +(setq scroll-conservatively 1000) + +(menu-bar-mode nil) +(tool-bar-mode nil) diff --git a/emacs-lisp/general/tempo-snippets.el b/emacs-lisp/general/tempo-snippets.el new file mode 100644 index 0000000..3e321f7 --- /dev/null +++ b/emacs-lisp/general/tempo-snippets.el @@ -0,0 +1,514 @@ +;;; tempo-snippets.el --- visual insertion of tempo templates +;; +;; Copyright (C) 2007 Nikolaj Schumacher;; +;; Author: Nikolaj Schumacher <bugs * nschum de> +;; Version: 0.1.2 +;; Keywords: abbrev convenience +;; URL: http://nschum.de/src/emacs/tempo-snippets/ +;; Compatibility: GNU Emacs 22.2 +;; +;; This file is NOT part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;; +;;; Commentary: +;; +;; IMPORTANT: +;; +;; Correct use of this package in C-derived (and maybe other) modes depends on +;; the following bug being fixed: +;; +;; http://lists.gnu.org/archive/html/emacs-devel/2007-08/msg00303.html +;; +;; Currently that's CVS Emacs only! +;; +;; +;; Add the following to your .emacs file: +;; (require 'tempo-snippets) +;; +;; Then use `tempo-define-snippet' instead of `tempo-define-template'. The +;; arguments can remain the same. Insertion works like for any tempo-template +;; with `tempo-template-your-template-name'. +;; +;; When adding lisp forms in your templates that use `tempo-lookup-named', make +;; sure they don't have side-effects, because they will be evaluated every time +;; the variables change. +;; +;; +;; Here are two examples: +;; +;; (tempo-define-snippet "java-class" +;; '("class " (p "Class: " class) " {\n\n" +;; > "public " (s class) "(" p ") {\n" > p n +;; "}" > n n "}" > n)) +;; +;; (tempo-define-snippet "java-get-set" +;; '("private " (p "Type: " type) " _" (p "Name: " var) ";\n\n" +;; > "public " (s type) " get" (upcase-initials (tempo-lookup-named 'var)) +;; "() {\n" +;; > "return _" (s var) ";\n" "}" > n n +;; > "public set" (upcase-initials (tempo-lookup-named 'var)) +;; "(" (s type) " value) {\n" +;; > "_" (s var) " = value;\n" "}" > n)) +;; +;; Note the forms in the second example. It calls `upcase-initials' every time +;; you change the first variable name. +;; +;; +;;; Changes Log: +;; +;; 2007-08-23 (0.1.2) +;; Added `tempo-snippets-complete-tag'. +;; +;; 2007-08-21 (0.1.1) +;; Fixed documentation. +;; Prevented crash when form returns nil. +;; Added `tempo-snippets-grow-in-front' option. +;; Proper clean-up of `tempo-marks' +;; Don't jump when first prompt is at point. +;; +;; 2007-08-21 (0.1) +;; Initial release. +;; +;;; Code: + +(require 'tempo) +(eval-when-compile (require 'cl)) + +(add-to-list 'debug-ignored-errors "^Beginning of buffer$") +(add-to-list 'debug-ignored-errors "^End of buffer$") + +(defgroup tempo-snippets nil + "Visual insertion of tempo templates." + :group 'abbrev + :group 'convenience) + +(defface tempo-snippets-editable-face + '((((background dark)) (:background "steel blue")) + (((background light)) (:background "light cyan"))) + "*Face used for editable text in tempo snippets." + :group 'tempo-snippets) + +(defface tempo-snippets-auto-face + '((((background dark)) (:underline "steel blue")) + (((background light)) (:underline "light cyan"))) + "*Face used for automatically updating text in tempo snippets." + :group 'tempo-snippets) + +(defface tempo-snippets-auto-form-face + '((default (:inherit 'tempo-snippets-auto-face))) + "*Face used for text in tempo snippets that is re-evaluated on input." + :group 'tempo-snippets) + +(defcustom tempo-snippets-interactive t + "*Insert prompts for snippets. +If this variable is nil, snippets work just like ordinary tempo-templates with +tempo-interactive set to nil." + :group 'tempo-snippets + :type '(choice (const :tag "Off" nil) + (const :tag "On" t))) + +(defcustom tempo-snippets-grow-in-front nil + "*If this is set, inserting text in front of a field will cause it to grow." + :group 'tempo-snippets + :type '(choice (const :tag "Off" nil) + (const :tag "On" t))) + +;;; tools ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun tempo-snippets-overlay-text (overlay) + (if overlay + (buffer-substring-no-properties (overlay-start overlay) + (overlay-end overlay)) + "")) + +(defun tempo-snippets-set-overlay-text (overlay text) + (when (overlay-buffer overlay) + (save-excursion + (let ((beg (overlay-start overlay)) + (inhibit-modification-hooks t)) + (goto-char beg) + (delete-char (- (overlay-end overlay) beg)) + (when text + (insert text)) + (move-overlay overlay beg (point)))))) + +;;; clearing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun tempo-snippets-clear-all () + "Clear all tempo-snippet overlays." + (interactive) + (kill-local-variable 'tempo-marks) + (dolist (s tempo-snippets-sources) + (tempo-snippets-finish-source s)) + (dolist (f tempo-snippets-forms) + (delete-overlay f)) + (kill-local-variable 'tempo-snippets-forms)) + +(defun tempo-snippets-clear (i) + "Clear a specific snippet." + (dolist (s tempo-snippets-sources) + (when (= i (car (overlay-get s 'tempo-snippets-save-name))) + (tempo-snippets-finish-source s))) + (dolist (f tempo-snippets-forms) + (when (= i (overlay-get f 'tempo-snippets-instance-counter)) + (delete-overlay f) + (setq tempo-snippets-forms (delq f tempo-snippets-forms))))) + +;;;###autoload +(defun tempo-snippets-clear-oldest () + "Clear the oldest tempo-snippet overlays." + (interactive) + (let ((minimum tempo-snippets-instance-counter)) + (dolist (s tempo-snippets-sources) + (setq minimum (min minimum + (car (overlay-get s 'tempo-snippets-save-name))))) + (tempo-snippets-clear minimum))) + +;;;###autoload +(defun tempo-snippets-clear-latest () + "Clear the latest tempo-snippet overlays." + (interactive) + (let ((maximum 0)) + (dolist (s tempo-snippets-sources) + (setq maximum (max maximum + (car (overlay-get s 'tempo-snippets-save-name))))) + (tempo-snippets-clear maximum))) + +;;; sources ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar tempo-snippets-sources nil + "The list of snippet input fields.") +(make-variable-buffer-local 'tempo-snippets-sources) + +(defun tempo-snippets-find-source (save-name &optional instance) + "Find an input field by name." + (setq save-name (cons (or instance + tempo-snippets-instance-counter) + save-name)) + (let ((sources tempo-snippets-sources) + match) + (while sources + (when (equal (overlay-get (car sources) 'tempo-snippets-save-name) + save-name) + (setq match (car sources) + sources nil)) + (pop sources)) + match)) + +(defun tempo-snippets-finish-source (overlay) + "Clear OVERLAY and its mirrors." + (dolist (o (overlay-get overlay 'tempo-snippets-mirrors)) + (delete-overlay o)) + (delete-overlay overlay) + (setq tempo-snippets-sources + (delq overlay tempo-snippets-sources))) + +(defun tempo-snippets-propagate-source (overlay) + "Propagate changes to source defined by OVERLAY." + (let ((text (tempo-snippets-overlay-text overlay)) + (mirrors (overlay-get overlay 'tempo-snippets-mirrors))) + ;; update mirrors + (dolist (o mirrors) + (unless (eq o overlay) + (tempo-snippets-set-overlay-text o text))) + ;; update forms + (tempo-snippets-update-forms))) + +;;; forms ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar tempo-snippets-forms nil + "The list of automatically re-evaluating snippet forms.") +(make-variable-buffer-local 'tempo-snippets-forms) + +(defun tempo-snippets-update-forms () + "Re-evaluate all forms." + (flet ((tempo-lookup-named (name) + (tempo-snippets-overlay-text + (tempo-snippets-find-source name)))) + (dolist (ov tempo-snippets-forms) + (if (overlay-buffer ov) + (let ((tempo-snippets-instance-counter + (overlay-get ov 'tempo-snippets-instance-counter))) + (tempo-snippets-set-overlay-text + ov (eval (overlay-get ov 'tempo-snippets-form)))) + (setq tempo-snippets-forms (delq ov tempo-snippets-forms)))))) + +(defun tempo-snippets-insert-form (form) + "Insert an automatically re-evaluating snippet form at point." + (let (overlay eval-result lookup-used) + ;; FIXME: check for handlers + (flet ((tempo-lookup-named (name) + (setq lookup-used t) + (tempo-snippets-overlay-text (tempo-snippets-find-source name)))) + (setq eval-result (eval form))) + (if lookup-used + (let ((beg (point))) + ;; XXX: this assumes on-region to be nil + (tempo-insert eval-result nil) + (setq overlay (make-overlay beg (point))) + (overlay-put overlay 'face 'tempo-snippets-auto-form-face) + ;; evaporating would cause problems when form before prompt! + (overlay-put overlay 'tempo-snippets-form form) + (overlay-put overlay 'modification-hooks + '(tempo-snippets-delete-overlay)) + (overlay-put overlay 'insert-in-front-hooks + '(tempo-snippets-dont-grow-overlay)) + (overlay-put overlay 'tempo-snippets-instance-counter + tempo-snippets-instance-counter) + (push overlay tempo-snippets-forms) + "") + eval-result))) + +;;; modification hooks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun tempo-snippets-update (ov after-p beg end &optional r) + "Called when a snippet input field is modified." + (when (and after-p (>= beg (overlay-start ov)) (<= beg (overlay-end ov))) + ;; grow overlay + (move-overlay ov (overlay-start ov) (max end (overlay-end ov))) + (tempo-snippets-propagate-source ov) + (when (= (overlay-end ov) (overlay-start ov)) + (if (> r 1) + ;; delete overlay and mirrors + (tempo-snippets-finish-source ov) + nil + ;; let's be nice and give back a prompt + (tempo-snippets-set-overlay-text + ov (overlay-get ov 'tempo-snippets-prompt)) + (tempo-snippets-propagate-source ov) + (overlay-put ov 'intangible t) + (overlay-put ov 'modification-hooks '(tempo-snippets-update)) + (overlay-put ov 'insert-behind-hooks nil) + (overlay-put ov 'insert-in-front-hooks '(tempo-snippets-replace)))))) + +(defun tempo-snippets-replace (overlay after-p beg end &optional r) + "Called when a snippet input prompt is modified." + (when after-p + (overlay-put overlay 'intangible nil) + (overlay-put overlay 'modification-hooks '(tempo-snippets-update)) + (overlay-put overlay 'insert-behind-hooks '(tempo-snippets-update)) + (overlay-put overlay 'insert-in-front-hooks + (if tempo-snippets-grow-in-front + '(tempo-snippets-update) + '(tempo-snippets-dont-grow-overlay))) + (let ((inhibit-modification-hooks t)) + (delete-region end (overlay-end overlay)) + (tempo-snippets-update overlay t beg end nil)))) + +;; Stores removed text for `tempo-snippets-delete-overlay'. +;; We need this, because fontification will call modification hooks, and we want +;; to delete the overlays only on actual text change +(defvar tempo-snippets-delete-overlay-text nil) + +(defun tempo-snippets-delete-overlay (ov after-p beg end &optional r) + "A wrapper to call `delete-overlay' from modification hooks." + (if after-p + (unless (string= tempo-snippets-delete-overlay-text + (buffer-substring-no-properties beg end)) + (delete-overlay ov)) + (setq tempo-snippets-delete-overlay-text + (buffer-substring-no-properties beg end)))) + +(defun tempo-snippets-dont-grow-overlay (ov after-p beg end &optional r) + "An insert-in-front hook that keeps the original text covered." + (when after-p + (move-overlay ov end (overlay-end ov)))) + +;;; insertions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun tempo-snippets-insert-source (prompt save-name) + "Insert a snippet prompt at point." + (tempo-insert-mark (point-marker)) + (let ((beg (point)) + (text (replace-regexp-in-string "[[:space:]]" "_" + (if (string-match "\\(.+\\): " prompt) + (match-string 1 prompt) + prompt))) + overlay) + (insert text) + (setq overlay (make-overlay beg (point))) + (overlay-put overlay 'tempo-snippets-save-name + (cons tempo-snippets-instance-counter save-name)) + (overlay-put overlay 'tempo-snippets-prompt text) + (overlay-put overlay 'face 'tempo-snippets-editable-face) + (overlay-put overlay 'intangible t) + (overlay-put overlay 'modification-hooks '(tempo-snippets-update)) + (overlay-put overlay 'insert-in-front-hooks '(tempo-snippets-replace)) + (overlay-put overlay 'tempo-snippets-source t) + (push overlay tempo-snippets-sources) + (tempo-snippets-propagate-source overlay) + )) + +(defun tempo-snippets-insert-mirror (save-name) + "Insert another instance of a snippet variable at point." + (let ((beg (point)) + (source (tempo-snippets-find-source save-name)) + overlay) + (when source + (insert (tempo-snippets-overlay-text source)) + (setq overlay (make-overlay beg (point))) + (let ((mirrors (overlay-get source 'tempo-snippets-mirrors))) + (push overlay mirrors) + (overlay-put source 'tempo-snippets-mirrors mirrors)) + (overlay-put overlay 'face 'tempo-snippets-auto-face) + (overlay-put overlay 'modification-hooks + '(tempo-snippets-delete-overlay)) + (overlay-put overlay 'insert-in-front-hooks + '(tempo-snippets-dont-grow-overlay))))) + +;;; navigation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun tempo-snippets-source-start-at-point (pos) + "Return the start of the snippet input field at point." + (let ((overlays (overlays-in (1- pos) pos)) result) + (while overlays + (when (overlay-get (car overlays) 'tempo-snippets-prompt) + (setq result (car overlays) + overlays nil)) + (pop overlays)) + (when result + (overlay-start result)))) + +;;;###autoload +(defun tempo-snippets-previous-field (&optional arg) + "Jump to the previous editable tempo-snippet field. +You can also use `tempo-forward-mark', which will include more points of +interest." + (interactive "p") + (let ((max-start (point-min)) + (pos (or (tempo-snippets-source-start-at-point (point)) (point))) + start) + (dolist (ov tempo-snippets-sources) + (setq start (overlay-start ov)) + (and (< start pos) + (> start max-start) + (setq max-start start))) + (when (= max-start (point-min)) + (error "Beginning of buffer")) + (push-mark) + (goto-char max-start))) + +;;;###autoload +(defun tempo-snippets-next-field (&optional arg) + "Jump to the next editable tempo-snippet field. +You can also use `tempo-backward-mark', which will include more points of +interest." + (interactive) + (let ((min-start (point-max)) + (pos (point)) + start) + (dolist (ov tempo-snippets-sources) + (setq start (overlay-start ov)) + (and (> start pos) + (< start min-start) + (setq min-start start))) + (when (= min-start (point-max)) + (error "End of buffer")) + (push-mark) + (goto-char min-start))) + +;;; overridden functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun tempo-snippets-insert-prompt (prompt &optional save-name no-insert) + "`tempo-snippets' version of `tempo-insert-prompt'" + (if tempo-interactive + (unless no-insert + (if (tempo-snippets-find-source save-name) + (tempo-snippets-insert-mirror save-name) + (tempo-snippets-insert-source prompt save-name)) + (unless (stringp prompt) + (error "tempo: The prompt (%s) is not a string" prompt))) + (tempo-insert-mark (point-marker)))) + +;;;###autoload +(defun tempo-define-snippet (name elements &optional tag documentation taglist) + "`tempo-snippets' version of `tempo-define-template'. +Use with the same arguments as `tempo-define-template'. The resulting template +will prompt for input right in the buffer instead of the minibuffer." + (let* ((template-name (intern (concat "tempo-template-" + name))) + (command-name template-name)) + (set template-name elements) + (fset command-name (list 'lambda (list '&optional 'arg) + (or documentation + (concat "Insert a " name ".")) + (list 'interactive "*P") + (list 'tempo-snippets-insert-template + (list 'quote template-name) + (list 'if 'tempo-insert-region + (list 'not 'arg) 'arg)))) + (put command-name 'no-self-insert t) + (and tag + (tempo-add-tag tag template-name taglist)) + command-name)) +(put 'tempo-define-snippet 'lisp-indent-function 1) + +(defvar tempo-snippets-instance-counter 0 + "Provides unique identifier for each snippet.") + +;;;###autoload +(defun tempo-snippets-insert-template (template on-region) + "`tempo-snippets' version of `tempo-insert-template.'" + (incf tempo-snippets-instance-counter) + (let ((tempo-user-elements '((lambda (element) + (tempo-snippets-insert-form element)))) + (tempo-interactive tempo-snippets-interactive) + (inhibit-modification-hooks t)) + (flet ((tempo-insert-named (name) (tempo-snippets-insert-mirror name)) + (tempo-insert-prompt (a &optional b c) + (tempo-snippets-insert-prompt a b c))) + (if (not tempo-interactive) + (tempo-insert-template template on-region) + (save-excursion (tempo-insert-template template on-region)) + (let ((overlays (overlays-at (point))) + match) + (while overlays + (when (overlay-get (pop overlays) 'tempo-snippets-save-name) + (setq overlays nil + match t))) + (unless match + (tempo-forward-mark)) + ;; return t so abbrevs don't insert space + t))))) + +;;;###autoload +(defun tempo-snippets-complete-tag (&optional silent) + "`tempo-snippets' version of `tempo-complete-tag.'" + ;; unfortunately this is a code clone of the original + ;; we can't use flet, because that would cause an infinite recursion + (interactive "*") + (let* ((collection (tempo-build-collection)) + (match-info (tempo-find-match-string tempo-match-finder)) + (match-string (car match-info)) + (match-start (cdr match-info)) + (exact (assoc match-string collection)) + (compl (or (car exact) + (and match-info (try-completion match-string collection))))) + (if compl (delete-region match-start (point))) + (cond ((null match-info) (or silent (ding))) + ((null compl) (or silent (ding))) + ((eq compl t) (funcall (cdr (assoc match-string collection)))) + (t (if (setq exact (assoc compl collection)) + (funcall (cdr exact)) + (insert compl) + (or silent (ding)) + (if tempo-show-completion-buffer + (tempo-display-completions match-string + collection))))))) + +(provide 'tempo-snippets) +;;; tempo-snippets.el ends here diff --git a/emacs-lisp/modes/cmode-stuff.el b/emacs-lisp/modes/cmode-stuff.el new file mode 100644 index 0000000..2b350e8 --- /dev/null +++ b/emacs-lisp/modes/cmode-stuff.el @@ -0,0 +1,37 @@ +(require 'cc-mode) + +;; Try to configure the C/C++ mode a little +(c-add-style "daniel" + '( + (c-basic-offset . 2) + (c-comment-only-line-offset . 0) + (c-offsets-alist . ( + (arglist-intro . c-lineup-arglist-intro-after-paren) + (arglist-close . c-lineup-arglist) + (substatement-open . 0) + (inline-open . 0) + ) + ) + ) +) + +(defun electric-c-newline (arg) + "Inserts a newline, and runs the indent command" + (interactive "P") + (c-indent-line) + (newline) + (c-indent-line) +) + +(add-hook 'c-mode-common-hook '(lambda () + (setq indent-tabs-mode t) + (c-set-style "linux") + (setq c-recognize-knr-p nil) +)) + +(define-key c-mode-map "\r" 'electric-c-newline) +(define-key c++-mode-map "\r" 'electric-c-newline) + +;; Finally do the thang + +(provide 'cmode-stuff) diff --git a/emacs-lisp/modes/fill-column-indicator.el b/emacs-lisp/modes/fill-column-indicator.el new file mode 100644 index 0000000..2dff943 --- /dev/null +++ b/emacs-lisp/modes/fill-column-indicator.el @@ -0,0 +1,814 @@ +;;; fill-column-indicator.el --- graphically indicate the fill column + +;; Copyright (c) 2011 Alp Aker + +;; Author: Alp Aker <alp.tekin.aker@gmail.com> +;; Version: 1.72 +;; Keywords: convenience + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; A copy of the GNU General Public License can be obtained from the +;; Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, +;; MA 02111-1307 USA + +;;; Commentary: + +;; Many modern editors and IDEs can graphically indicate the location of the +;; fill column by drawing a thin line (in design parlance, a `rule') down the +;; length of the editing window. Fill-column-indicator implements this +;; facility in Emacs. + +;; Installation and Usage +;; ====================== + +;; Put this file in your load path and put +;; +;; (require 'fill-column-indicator) +;; +;; in your .emacs. + +;; To toggle graphical indication of the fill column in a buffer, use the +;; command `fci-mode'. + +;; Configuration +;; ============= + +;; On graphical displays the fill-column rule is drawn using a bitmap +;; image. Its color is controlled by the variable `fci-rule-color', whose +;; value can be any valid color name. The rule's width in pixels is +;; determined by the variable `fci-rule-width'; the default value is 2. + +;; The image formats fci-mode can use are XPM, PBM, and XBM. If Emacs has +;; been compiled with the appropriate library it uses XPM images by default; +;; if not it uses PBM images, which are natively supported. You can specify +;; a particular format by setting `fci-rule-image-format' to either xpm, +;; xpm, or xbm. + +;; On character terminals the rule is drawn using the character specified by +;; `fci-rule-character'; the default is `|' (ascii 124). If +;; `fci-rule-character-color' is nil, then it is drawn using fci-rule-color +;; (or the closest approximation thereto that the terminal is capable of); if +;; it is a color name, then that color is used instead. + +;; If you'd like the rule to be drawn using fci-rule-character even on +;; graphical displays, set `fci-always-use-textual-rule' to a non-nil value. + +;; These variables (as well as those in the next section) can be given +;; buffer-local bindings. + +;; Other Options +;; ============= + +;; When `truncate-lines' is nil, the effect of drawing a fill-column rule is +;; very odd looking. Indeed, it makes little sense to use a rule to indicate +;; the position of the fill column in that case (the positions at which the +;; fill column falls in the visual display space won't in general be +;; collinear). For this reason, fci-mode sets truncate-lines to t in buffers +;; in which it is enabled and restores it to its previous value when +;; disabled. You can turn this feature off by setting +;; `fci-handle-truncate-lines' to nil. + +;; If `line-move-visual' is t, then vertical navigation can behave oddly in +;; several edge cases while fci-mode is enabled (this is due to a bug in C +;; code). Accordingly, fci-mode sets line-move-visual to nil in buffers in +;; which it is enabled and restores it to its previous value when +;; disabled. This can be suppressed by setting `fci-handle-line-move-visual' +;; to nil. (But you shouldn't want to do this. There's no reason to use +;; line-move-visual if truncate-lines is t, and it doesn't make sense to use +;; something like fci-mode when truncate-lines is nil.) + +;; Fci-mode needs free use of two characters (specifically, it needs the use +;; of two characters whose display table entries it can change +;; arbitrarily). By default, it uses the first two characters of the Private +;; Use Area of the Unicode BMP, viz. U+E000 and U+E001. If you need to use +;; those characters for some other purpose, set `fci-eol-char' and +;; `fci-blank-char' to different values. + +;; Troubleshooting +;; =============== + +;; o Fci-mode is intended to be used with monospaced fonts. If you're using +;; a monospaced font and the fill-column rule is missing or misaligned on a +;; few lines but otherwise appears normal, then most likely (a) there are +;; non-ascii characters on those lines that are being displayed using a +;; non-monospaced font, or (b) your font-lock settings use bold or italics +;; and those font variants aren't monospaced. + +;; o Although the XBM and PBM formats are natively supported by Emacs, the +;; implementations are different in different ports and sometimes +;; incomplete; for example, on some ports XBM images are always drawn in +;; black. Explicitly setting `fci-rule-image-format' to a different value +;; will usually resolve such issues. + +;; Known Issues +;; ============ + +;; o The indicator extends only to end of the buffer contents (as opposed to +;; running the full length of the editing window). + +;; o When portions of a buffer are invisible, such as when outline-mode is +;; used to hide certain lines, the fill-column rule is hidden as well. + +;; o Fci-mode should work smoothly when simultaneously displaying the same +;; buffer on both a graphical display and on a character terminal. It does +;; not currently support simultaneous display of the same buffer on window +;; frames with different default font sizes. (It would be feasible to +;; support this use case, but thus far there seems to be no demand for +;; it.) + +;; o An issue specific to the Mac OS X (NextStep) port, versions 23.0-23.2: +;; Emacs won't, in these particular versions, draw a cursor on top of an +;; image. Thus on graphical displays the cursor will disappear when +;; positioned directly on top of the fill-column rule. The best way to +;; deal with this is to upgrade to v23.3 or v24 (or downgrade to v22). If +;; that isn't practical, a fix is available via the mini-package +;; fci-osx-23-fix.el, which can be downloaded from: +;; +;; github.com/alpaker/Fill-Column-Indicator +;; +;; Directions for its use are given in the file header. + +;; Todo +;; ==== + +;; o Accommodate non-nil values of `hl-line-sticky-flag' and similar cases. + +;; o Accommodate linum-mode more robustly. + +;; o Compatibility with non-nil `show-trailing-whitespace.' + +;;; Code: + +(unless (version<= "22" emacs-version) + (error "Fill-column-indicator requires version 22 or later")) + +;;; --------------------------------------------------------------------- +;;; User Options +;;; --------------------------------------------------------------------- + +(defgroup fill-column-indicator nil + "Graphically indicate the fill-column." + :tag "Fill-Column Indicator" + :group 'convenience + :group 'fill) + +(defcustom fci-rule-color "#cccccc" + "Color used to draw the fill-column rule. + +Changes to this variable do not take effect until the mode +function `fci-mode' is run." + :group 'fill-column-indicator + :tag "Fill-column rule color" + :type 'color) + +;; We should be using :validate instead of :match, but that seems not to +;; work with defcustom widgets. +(defcustom fci-rule-width 2 + "Width in pixels of the fill-column rule on graphical displays. +Note that a value greater than the default character width is +treated as equivalent to the default character width. + +Changes to this variable do not take effect until the mode +function `fci-mode' is run." + :tag "Fill-Column Rule Width" + :group 'fill-column-indicator + :type '(integer :match (lambda (w val) (wholenump val)))) + +(defcustom fci-rule-image-format + (if (image-type-available-p 'xpm) 'xpm 'pbm) + "Image format used for the fill-column rule on graphical displays. + +Changes to this variable do not take effect until the mode +function `fci-mode' is run." + :tag "Fill-Column Rule Image Format" + :group 'fill-column-indicator + :type '(choice (symbol :tag "XPM" 'xpm) + (symbol :tag "PBM" 'pbm) + (symbol :tag "XBM" 'xbm))) + +(defcustom fci-rule-character ?| + "Character use to draw the fill-column rule on character terminals. + +Changes to this variable do not take effect until the mode +function `fci-mode' is run." + :tag "Fill-Column Rule Character" + :group 'fill-column-indicator + :type 'character) + +(defcustom fci-rule-character-color nil + "Color used to draw the fill-column rule on character terminals. +If nil, the same color is used as for the graphical rule. + +Changes to this variable do not take effect until the mode +function `fci-mode' is run." + :group 'fill-column-indicator + :tag "Fill-column rule color" + :type '(choice (const :tag "Use same color as graphical rule" nil) + (color :tag "Specify a color"))) + +(defcustom fci-always-use-textual-rule nil + "When non-nil, the rule is always drawn using textual characters. +Specifically, fci-mode will use `fci-rule-character' intead of +bitmap images to draw the rule on graphical displays. + +Changes to this variable do not take effect until the mode +function `fci-mode' is run." + :tag "Don't Use Image for Fill-Column Rule" + :group 'fill-column-indicator + :type 'boolean) + +(defcustom fci-handle-truncate-lines t + "Whether fci-mode should set truncate-lines to t while enabled. +If non-nil, fci-mode will set truncate-lines to t in buffers in +which it is enabled, and restore it to its previous value when +disabled. + +Leaving this option set to the default value is recommended." + :group 'fill-column-indicator + :tag "Locally set truncate-lines to t during fci-mode" + :type 'boolean) + +(defcustom fci-handle-line-move-visual (version<= "23" emacs-version) + "Whether fci-mode should set line-move-visual to nil while enabled. +If non-nil, fci-mode will set line-move-visual to nil in buffers +in which it is enabled, and restore t to its previous value when +disabled. + +Leaving this option set to the default value is recommended." + :group 'fill-column-indicator + :tag "Locally set line-move-visual to nil during fci-mode" + :type 'boolean) + +(defcustom fci-eol-char ?\uE000 + "Character used for internal purposes by fci-mode. +If you need to use this character, set this variable's value to a +character you do not care about (a good choice is a character +from the Private Use Area of the Unicode BMP, i.e., the range +U+E000-U+F8FF, inclusive)." + :group 'fill-column-indicator + :type 'character) + +(defcustom fci-blank-char ?\uE001 + "Character used for internal purposes by fci-mode. +If you need to use this character, set this variable's value to a +character you do not care about (a good choice is a character +from the Private Use Area of the Unicode BMP, i.e., the the range +U+E000-U+F8FF, inclusive)." + :group 'fill-column-indicator + :type 'character) + +;;; --------------------------------------------------------------------- +;;; Internal Variables and Constants +;;; --------------------------------------------------------------------- + +;; Record prior state of buffer. +(defvar fci-saved-line-move-visual nil) +(defvar fci-saved-truncate-lines nil) +(defvar fci-saved-eol nil) +(defvar fci-made-display-table nil) + +;; Record state of fci initialization in this buffer. +(defvar fci-display-table-processed nil) +(defvar fci-local-vars-set nil) + +;; Record current state of some quantities, so we can detect changes to them. +(defvar fci-column nil) +(defvar fci-newline-sentinel nil) +(defvar fci-tab-width nil) +(defvar fci-char-width nil) +(defvar fci-char-height nil) + +;; Data used in setting the fill-column rule that only need to be +;; occasionally updated in a given buffer. +(defvar fci-limit nil) +(defvar fci-pre-limit-string nil) +(defvar fci-at-limit-string nil) +(defvar fci-post-limit-string nil) + +;; The preceding internal variables need to be buffer local and reset when +;; the mode is disabled. +(defconst fci-internal-vars '(fci-saved-line-move-visual + fci-saved-truncate-lines + fci-saved-eol + fci-made-display-table + fci-display-table-processed + fci-local-vars-set + fci-column + fci-newline-sentinel + fci-tab-width + fci-char-width + fci-char-height + fci-limit + fci-pre-limit-string + fci-at-limit-string + fci-post-limit-string)) + +(dolist (var fci-internal-vars) + (make-variable-buffer-local var)) + +;; Hooks we use. +(defconst fci-hook-assignments + '((after-change-functions . fci-redraw-region) + (before-change-functions . fci-extend-rule-for-deletion) + (window-scroll-functions . fci-update-window-for-scroll) + (window-configuration-change-hook . fci-schedule-full-update) + (post-command-hook . fci-post-command-check) + (change-major-mode-hook . (lambda () (fci-mode 0))) + (longlines-mode-hook . fci-full-update))) + +;; The display spec used in overlay before strings to pad out the rule to the +;; fill-column. +(defconst fci-padding-display + '((when (fci-overlay-check buffer-position) + . (space :align-to fci-column)) + (space :width 0))) + +;;; --------------------------------------------------------------------- +;;; Miscellaneous Utilities +;;; --------------------------------------------------------------------- + +(if (fboundp 'characterp) + (defalias 'fci-character-p 'characterp) + ;; For v22. + (defun fci-character-p (c) + (and (wholenump c) + (/= 0 c) + ;; MAX_CHAR in v22 is (0x1F << 14). We don't worry about + ;; generic chars. + (< c 507904)))) + +(defun fci-get-buffer-windows () + "Return a list of windows displaying the current buffer." + (get-buffer-window-list (current-buffer) 'no-minibuf t)) + +;;; --------------------------------------------------------------------- +;;; Mode Definition +;;; --------------------------------------------------------------------- + +(define-minor-mode fci-mode + "Toggle fci-mode on and off. +Fci-mode indicates the location of the fill column by drawing a +thin line (a `rule') at the fill column. + +With prefix ARG, turn fci-mode on if and only if ARG is positive. + +The following options control the appearance of the fill-column +rule: `fci-rule-width', `fci-rule-color', +`fci-rule-character', and `fci-rule-character-color'. For +further options, see the Customization menu or the package +file. (See the latter for tips on troubleshooting.)" + + nil nil nil + + (if fci-mode + ;; Enabling. + (condition-case error + (progn + (fci-check-user-options) + (fci-process-display-table) + (fci-set-local-vars) + (dolist (hook fci-hook-assignments) + (add-hook (car hook) (cdr hook) nil t)) + (setq fci-column fill-column + fci-tab-width tab-width + fci-limit (if fci-newline-sentinel + (1+ (- fill-column (length fci-saved-eol))) + fill-column)) + (fci-make-overlay-strings) + (fci-full-update)) + (error + (fci-mode 0) + (signal (car error) (cdr error)))) + + ;; Disabling. + (fci-restore-display-table) + (fci-restore-local-vars) + (dolist (hook fci-hook-assignments) + (remove-hook (car hook) (cdr hook) t)) + (remove-hook 'post-command-hook #'fci-full-update t) + (fci-delete-overlays-buffer) + (dolist (var fci-internal-vars) + (set var nil)))) + +;;; --------------------------------------------------------------------- +;;; Enabling +;;; --------------------------------------------------------------------- + +(defun fci-check-user-options () + "Check that all user options for fci-mode have valid values." + (unless (memq fci-rule-image-format '(xpm xbm pbm)) + (error "Unrecognized value of `fci-rule-image-format'")) + (when (and fci-rule-character-color + (not (color-defined-p fci-rule-character-color))) + (signal 'wrong-type-argument `(color-defined-p ,fci-rule-character-color))) + (let ((checks `((color-defined-p . ,fci-rule-color) + (fci-character-p . ,fci-rule-character) + (fci-character-p . ,fci-blank-char) + (fci-character-p . ,fci-eol-char) + (wholenump . ,fci-rule-width)))) + (dolist (check checks) + (unless (funcall (car check) (cdr check)) + (signal 'wrong-type-argument (list (car check) (cdr check))))))) + +(defun fci-process-display-table () + "Set up a buffer-local display table for fci-mode." + (unless fci-display-table-processed + (unless buffer-display-table + (setq buffer-display-table (make-display-table) + fci-made-display-table t)) + (aset buffer-display-table fci-blank-char [32]) + (setq fci-saved-eol (aref buffer-display-table 10)) + ;; Assumption: the display-table entry for character 10 is either nil or + ;; a vector whose last element is the newline glyph. + (let ((glyphs (butlast (append fci-saved-eol nil))) + eol) + (if glyphs + (setq fci-newline-sentinel [10] + eol (vconcat glyphs)) + (setq fci-newline-sentinel nil + eol [32])) + (aset buffer-display-table 10 fci-newline-sentinel) + (aset buffer-display-table fci-eol-char eol)) + (setq fci-display-table-processed t))) + +(defun fci-set-local-vars () + "Set miscellaneous local variables when fci-mode is enabled." + (unless fci-local-vars-set + (when (and fci-handle-line-move-visual + (boundp 'line-move-visual)) + (if (local-variable-p 'line-move-visual) + (setq fci-saved-line-move-visual (list line-move-visual) + line-move-visual nil) + (set (make-local-variable 'line-move-visual) nil))) + (when fci-handle-truncate-lines + (setq fci-saved-truncate-lines truncate-lines + truncate-lines t)) + (setq fci-local-vars-set t))) + +(defun fci-make-rule-string () + "Return a string for drawing the fill-column rule." + (let ((color (or fci-rule-character-color + fci-rule-color))) + ;; Make sure we don't pick up weight or slant from font-lock. + (propertize (char-to-string fci-rule-character) + 'face `(:foreground ,color :weight normal :slant normal)))) + +(defun fci-make-img-descriptor () + "Make an image descriptor for the fill-column rule." + (unless fci-always-use-textual-rule + (let ((frame (catch 'found-graphic + (if (display-images-p) + (selected-frame) + (dolist (win (fci-get-buffer-windows)) + (when (display-images-p (window-frame win)) + (throw 'found-graphic (window-frame win)))))))) + (setq fci-char-width (frame-char-width frame) + fci-char-height (frame-char-height frame)) + ;; No point passing width, height, color etc. directly to the image + ;; functions: those variables need to have either global or + ;; buffer-local scope, so the image functions can access them directly. + (if frame + (cond + ((eq fci-rule-image-format 'xpm) + (fci-make-xpm-img)) + ((eq fci-rule-image-format 'pbm) + (fci-make-pbm-img)) + (t + (fci-make-xbm-img))))))) + +(defun fci-make-xbm-img () + "Return an image descriptor for the fill-column rule in XBM format." + (let* ((img-width (* 8 (/ (+ fci-char-width 7) 8))) + (row-pixels (make-bool-vector img-width nil)) + (raster (make-vector fci-char-height row-pixels)) + (rule-width (min fci-rule-width fci-char-width)) + (left-margin (/ (- img-width rule-width) 2))) + (dotimes (i rule-width) + (aset row-pixels (+ i left-margin) t)) + `(image :type xbm + :data ,raster + :foreground ,fci-rule-color + :mask heuristic + :ascent center + :height ,fci-char-height + :width ,img-width))) + +(defun fci-make-pbm-img () + "Return an image descriptor for the fill-column rule in PBM format." + (let* ((height-str (number-to-string fci-char-height)) + (width-str (number-to-string fci-char-width)) + (rule-width (min fci-rule-width fci-char-width)) + (margin (/ (- fci-char-width rule-width) 2.0)) + (left-margin (floor margin)) + (right-margin (ceiling margin)) + (identifier "P1\n") + (dimens (concat width-str " " height-str "\n")) + (left-pixels (mapconcat #'identity (make-list left-margin "0") " ")) + (rule-pixels (mapconcat #'identity (make-list rule-width "1") " ")) + (right-pixels (mapconcat #'identity (make-list right-margin "0") " ")) + (row-pixels (concat left-pixels " " rule-pixels " " right-pixels)) + (raster (mapconcat #'identity + (make-list fci-char-height row-pixels) + "\n")) + (data (concat identifier dimens raster))) + `(image :type pbm + :data ,data + :mask heuristic + :foreground ,fci-rule-color + :ascent center))) + +(defun fci-make-xpm-img () + "Return an image descriptor for the fill-column rule in XPM format." + (let* ((height-str (number-to-string fci-char-height)) + (width-str (number-to-string fci-char-width)) + (rule-width (min fci-rule-width fci-char-width)) + (margin (/ (- fci-char-width rule-width) 2.0)) + (left-margin (floor margin)) + (right-margin (ceiling margin)) + (identifier "/* XPM */\nstatic char *rule[] = {\n") + (dims (concat "\"" width-str " " height-str " 2 1\",\n")) + (color-spec (concat "\"1 c " fci-rule-color "\",\n \"0 c None\",\n")) + (row-pixels (concat "\"" + (make-string left-margin ?0) + (make-string rule-width ?1) + (make-string right-margin ?0) + "\",\n")) + (raster (mapconcat #'identity + (make-list fci-char-height row-pixels) + "")) + (end "};") + (data (concat identifier dims color-spec raster end))) + `(image :type xpm + :data ,data + :mask heuristic + :ascent center))) + + +;; Generate the display spec for the rule. Basic idea is to use a "cascading +;; display property" to display the textual rule if the display doesn't +;; support images and the graphical rule if it does, but in either case only +;; display a rule if no other overlay wants to fill the background at the +;; relevant buffer position. +(defun fci-rule-display (blank img str pre) + "Generate a display specification for a fill-column rule overlay string." + (let ((cursor (if (and (not pre) (not fci-newline-sentinel)) 1))) + (propertize blank + 'cursor cursor + 'display + (if img + `((when (and (not (display-images-p)) + (fci-overlay-check buffer-position)) + . ,(propertize str 'cursor cursor)) + (when (fci-overlay-check buffer-position) + . ,img) + (space :width 0)) + `((when (fci-overlay-check buffer-position) + . ,(propertize str 'cursor cursor)) + (space :width 0)))))) + +(defun fci-make-overlay-strings () + "Generate the overlay strings used to display the fill-column rule." + (let* ((str (fci-make-rule-string)) + (img (fci-make-img-descriptor)) + (blank-str (char-to-string fci-blank-char)) + (eol-str (char-to-string fci-eol-char)) + (end-cap (propertize blank-str 'display '(space :width 0))) + (pre-post-eol (propertize eol-str + 'cursor 1 + 'display (propertize eol-str 'cursor 1))) + (pre-padding (propertize blank-str 'display fci-padding-display)) + (pre-rule (fci-rule-display blank-str img str t)) + (at-rule (fci-rule-display blank-str img str fci-newline-sentinel)) + (at-eol (if fci-newline-sentinel pre-post-eol ""))) + (setq fci-pre-limit-string (concat pre-post-eol pre-padding pre-rule) + fci-at-limit-string (concat at-eol at-rule) + fci-post-limit-string (concat pre-post-eol end-cap)))) + +;;; --------------------------------------------------------------------- +;;; Disabling +;;; --------------------------------------------------------------------- + +(defun fci-restore-local-vars () + "Restore miscellaneous local variables when fci-mode is disabled." + (when fci-local-vars-set + (when (and fci-handle-line-move-visual + (boundp 'line-move-visual)) + (if fci-saved-line-move-visual + (setq line-move-visual (car fci-saved-line-move-visual)) + (kill-local-variable 'line-move-visual))) + (when fci-handle-truncate-lines + (setq truncate-lines fci-saved-truncate-lines)))) + +(defun fci-restore-display-table () + "Restore the buffer display table when fci-mode is disabled." + (when (and buffer-display-table + fci-display-table-processed) + (aset buffer-display-table 10 fci-saved-eol) + ;; Don't set buffer-display-table to nil even if we created the display + ;; table; only do so if nothing else has changed it. + (when (and fci-made-display-table + (equal buffer-display-table (make-display-table))) + (setq buffer-display-table nil)))) + +;;; --------------------------------------------------------------------- +;;; Drawing and Erasing +;;; --------------------------------------------------------------------- + +(defun fci-overlay-check (pos) + "Return true if there is an overlay at POS that fills the background." + (not (memq t (mapcar #'(lambda (x) + (and (overlay-get x 'face) + (not (eq (face-attribute + (overlay-get x 'face) + :background nil t) + 'unspecified)))) + (overlays-at pos))))) + +(defmacro fci-sanitize-actions (&rest body) + "Wrap fill-column rule-drawing functions in protective special forms." + `(save-match-data + (save-excursion + (let ((inhibit-point-motion-hooks t)) + ,@body)))) + +(defun fci-get-overlays-region (start end) + "Return all overlays between START and END displaying the fill-column rule." + (delq nil (mapcar #'(lambda (o) (if (overlay-get o 'fci) o)) + (overlays-in start end)))) + +(defun fci-delete-unneeded () + "Erase the fill-column rule at buffer positions not visible in any window." + (let ((olays (fci-get-overlays-region (point-min) (point-max))) + (ranges (mapcar #'(lambda (w) + (cons (window-start w) (window-end w t))) + (fci-get-buffer-windows))) + pos) + (dolist (o olays) + (setq pos (overlay-start o)) + (unless (memq t (mapcar #'(lambda (range) + (and (<= (car range) pos) + (< pos (cdr range)))) + ranges)) + (delete-overlay o))))) + +(defun fci-delete-overlays-region (start end) + "Delete overlays displaying the fill-column rule between START and END." + (mapc #'(lambda (o) (if (overlay-get o 'fci) (delete-overlay o))) + (overlays-in start end))) + +;; It would be slightly faster to run this backwards from END to START, but +;; only if we maintained the overlay center at an early position in the +;; buffer. Since other packages that use overlays typically place them while +;; traversing the buffer in a forward direction, that would be a bad idea. +(defun fci-put-overlays-region (start end) + "Place overlays displaying the fill-column rule between START and END." + (goto-char start) + (let (o cc) + (while (search-forward "\n" end t) + (goto-char (match-beginning 0)) + (setq cc (current-column) + o (make-overlay (match-beginning 0) (match-beginning 0))) + (overlay-put o 'fci t) + (cond + ((< cc fci-limit) + (overlay-put o 'after-string fci-pre-limit-string)) + ((> cc fci-limit) + (overlay-put o 'after-string fci-post-limit-string)) + (t + (overlay-put o 'after-string fci-at-limit-string))) + (goto-char (match-end 0))))) + +(defun fci-redraw-region (start end _ignored) + "Erase and redraw the fill-column rule between START and END." + (fci-sanitize-actions + (goto-char end) + (setq end (line-beginning-position 2)) + (fci-delete-overlays-region start end) + (fci-put-overlays-region start end))) + +(defun fci-update-window-for-scroll (win start) + "Redraw the fill-column rule in WIN after it has been been scrolled." + (fci-sanitize-actions + (fci-delete-unneeded) + (let ((end (window-end win t))) + (fci-delete-overlays-region start end) + (fci-put-overlays-region start end)))) + +;; This doesn't determine the strictly minimum amount by which the rule needs +;; to be extended, but the amount used is always sufficient, and the extra +;; computation involved in determining the genuine minimum is more expensive +;; than doing the extra drawing. +(defun fci-extend-rule-for-deletion (start end) + "Extend the fill-column rule after a deletion that spans newlines." + (unless (= start end) + (let ((delenda (fci-get-overlays-region start end))) + (when delenda + (mapc #'delete-overlay delenda) + (let ((lossage 0) + (max-end 0) + win-end) + (dolist (win (fci-get-buffer-windows)) + ;; Do not ask for an updated value of window-end. + (setq win-end (window-end win)) + (when (and (< 0 (- (min win-end end) + (max (window-start win) start))) + (< max-end win-end)) + (setq max-end win-end))) + (unless (= max-end (point-max)) + (save-excursion + (goto-char start) + (while (search-forward "\n" end t) + (setq lossage (1+ lossage)))) + (fci-redraw-region max-end + (save-excursion + (goto-char max-end) + (line-beginning-position lossage)) + nil))))))) + +;; If N windows display the buffer, then window-configuration-change-hook +;; calls this function N times. Since we only need to run the window update +;; once, we engage in a bit of misdirection and incur the lesser cost of N-1 +;; unnecessary calls to `add-hook'. +(defun fci-schedule-full-update () + "Arrange to redraw the fill-column rule in all windows on this buffer." + (add-hook 'post-command-hook #'fci-full-update nil t)) + +(defun fci-full-update () + "Redraw the fill-column rule in all windows on this buffer." + (remove-hook 'post-command-hook #'fci-full-update t) + (overlay-recenter (point-max)) + (fci-delete-unneeded) + (let (start end) + (fci-sanitize-actions + ;; If some windows on this buffer overlap, we end up redrawing the rule + ;; in the overlapped area multiple times, but it's faster to do that + ;; than do the computations needed to avoid such redrawing. + (dolist (win (fci-get-buffer-windows)) + (setq start (window-start win) + end (window-end win t)) + (fci-delete-overlays-region start end) + (fci-put-overlays-region start end))))) + +(defun fci-delete-overlays-buffer () + "Delete all overlays displaying the fill-column rule in the current buffer." + (save-restriction + (widen) + (fci-delete-overlays-region (point-min) (point-max)))) + +;;; --------------------------------------------------------------------- +;;; Workarounds +;;; --------------------------------------------------------------------- + +;; This in placed in post-command-hook and does four things: +;; 1. If the display table has been deleted or something has changed the +;; display table for newline chars, we regenerate overlay strings after +;; reprocessing the display table. +;; 2. If the default char width or height has changed, we regenerate the rule +;; image. (This handles both font changes and also cases where we +;; activate the mode while displaying on a char terminal then subsequently +;; display the buffer on a window frame.) +;; 3. If the value of `tab-width' or `fill-column' has changed, we reset the +;; rule. (We could set things up so that the rule adjusted automatically +;; to such changes, but it wouldn't work on v22 or v23.) +;; 4. Cursor properties are ignored when they're out of sight because of +;; horizontal scrolling. We detect such situations and force a return +;; from hscrolling to bring our requested cursor position back into view. +;; These are all fast tests, so despite the large remit this function +;; doesn't have any effect on editing speed. (Typical case run-time +;; benchmarks at 10e-6 on my machine.) +(defun fci-post-command-check () + (cond + ((not (and buffer-display-table + (equal (aref buffer-display-table 10) fci-newline-sentinel))) + (setq fci-display-table-processed nil) + (fci-mode 1)) + ((and (< 1 (frame-char-width)) + (not fci-always-use-textual-rule) + (not (and (= (frame-char-width) fci-char-width) + (= (frame-char-height) fci-char-height)))) + (fci-mode 1)) + ((not (and (= fill-column fci-column) + (= tab-width fci-tab-width))) + (fci-mode 1)) + ((and (< 0 (window-hscroll)) + auto-hscroll-mode + (<= (current-column) (window-hscroll))) + ;; Fix me: Rather than setting hscroll to 0, this should reproduce the + ;; relevant part of the auto-hscrolling algorithm. Most people won't + ;; notice the difference in behavior, though. + (set-window-hscroll (selected-window) 0)))) + +(provide 'fill-column-indicator) + +;;; fill-column-indicator.el ends here + + diff --git a/emacs-lisp/modes/hfy.el b/emacs-lisp/modes/hfy.el new file mode 100644 index 0000000..e7a132d --- /dev/null +++ b/emacs-lisp/modes/hfy.el @@ -0,0 +1,728 @@ +;; This code released under the GNU GPL (v2) +;; ( A copy of which you can find at +;; http://rtfm.etla.org/sql/oracle_time/gpl.html ) + +;; Copyright (C) 2002 Vivek Dasmohapatra <vivek@etla.org> + +;; here's some emacs code to html-pretty-print an emacs buffer, preserving +;; the emacs syntax/whatever highlighting + +;; Have added code to drive the htmlfontification code in an even funkier +;; way (hfy-copy-and-fontify-dir "/src/directory" "/dst/directory") is +;; capable of generating and harvesting an etags index for that source +;; tree and using it to generate hyperlinked-and-fontified files. + +;; NOTE: Currently the hyperlinking code only knows how to drive GNU find +;; and the exuberant-ctags variant of etags (on platforms where the -R +;; (recursion) switch is implemented). I will probably adapt this code to +;; drive other variants of etags - I am much less likely to support other +;; variants of find, though, unless they support the -path test. + +;; hmm, must write some proper docs for this - still, it should be +;; reasonably easy to follow, though... + +;; A sample of the htmlfontified / hyperlinked output of this module can be +;; found at http://rtfm.etla.org/sql/dbishell/src/ - it's not perfect, but +;; it's a hell of a lot faster and more through than I could hope to be +;; doing this by hand. + +;; some user / horrified onlooker comments: +;; What? No! There's something deeply wrong here... (R. Shufflebotham) +;; You're a freak. (D. Silverstone) +;; Aren't we giving you enough to do? (J. Busuttil) +(defvar hfy-page-header 'hfy-default-header) + +(defvar hfy-page-footer 'hfy-default-footer) + +(defvar hfy-extn ".html") + +(defvar hfy-link-extn nil) + +(defvar hfy-index-file "hfy-index") + +(defvar hfy-tags-cache nil) + +(defvar hfy-tags-sortl nil) + +(defvar hfy-etags-cmd "etags -R -f -") + +(defvar hfy-find-cmd + "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*") + +(defun hfy-default-header (file) + "<html>\n<body bgcolor=\"black\" text=\"white\">\n") + +(defun hfy-default-footer (file) "</body>\n</html>") +;; utility functions - cast emacs style specification values into their +;; css2 equivalents: +(defun hfy-triplet (colour) + "Takes a colour name (string) and return a css rgb(R, G, B) triplet string. +Uses the definition of \"white\" to map the numbers to the 0-255 range, so +if you\'ve redefined white, (esp if you've redefined it to have a triplet +member lower than that of the colour you are processing, strange things +may happen)" + (let ((white (mapcar (lambda (I) (float (1+ I))) (color-values "white"))) + (rgb16 (mapcar (lambda (I) (float (1+ I))) (color-values colour)))) + (if rgb16 + (apply 'format "rgb(%d, %d, %d)" + (mapcar (lambda (X) + (* (/ (nth X rgb16) + (nth X white)) 255)) '(0 1 2))))) ) + +(defun hfy-family (family) (list (cons "font-family" family))) +(defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour)))) +(defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour)))) +(defun hfy-width (width) (list (cons "font-stretch" (symbol-name width)))) + +(defun hfy-size (height) + "Derive a css font-size specifier from an emacs font :height attribute. +Does not cope with the case where height is a function to be applied to +the height of the underlying font" + (list + (cond + ((floatp height) (cons "font-size" (format "%d%%" (* height 100)))) + ((integerp height) (cons "font-size" (format "%dpt" (/ height 10 )))) )) ) + +(defun hfy-slant (slant) + "Derive a font-style css specifier from the emacs :slant attribute - +CSS does not define the reverse-* styles, so just maps those to the +regular specifiers." + (list (cons "font-style" (cond ((eq 'italic slant) "italic" ) + ((eq 'reverse-italic slant) "italic" ) + ((eq 'oblique slant) "oblique") + ((eq 'reverse-oblique slant) "oblique") + (t "normal" )))) ) +(defun hfy-weight (weight) + (list (cons "font-weight" (cond ((eq 'ultra-bold weight) "900") + ((eq 'extra-bold weight) "800") + ((eq 'bold weight) "700") + ((eq 'semi-bold weight) "600") + ((eq 'normal weight) "500") + ((eq 'semi-light weight) "400") + ((eq 'light weight) "300") + ((eq 'extra-light weight) "200") + ((eq 'ultra-light weight) "100")))) ) + +(defun hfy-box-to-border-assoc (spec) + (if spec + (let ((tag (car spec)) + (val (cadr spec))) + (cons (cond ((string= tag ":color") (cons "colour" val)) + ((string= tag ":width") (cons "width" val)) + ((string= tag ":style") (cons "style" val))) + (hfy-box-to-border-assoc (cddr spec))))) ) + +(defun hfy-box-to-style (spec) + (let* ((css (hfy-box-to-border-assoc spec)) + (col (cdr (assoc "colour" css))) + (s (cdr (assoc "style" css)))) + (list + (if col (cons "border-color" (cdr (assoc "colour" css)))) + (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1))) + (cons "border-style" (cond ((string= s "released-button") "outset") + ((string= s "released-button") "inset" ) + (t "solid" ))))) ) + +(defun hfy-box (box) + "Derive CSS border-* attributes from the emacs :box attribute." + (if box + (cond + ((integerp box) (list (cons "border-width" (format "%dpx" box)))) + ((stringp box) (list (cons "border" (format "solid %s 1px" box)))) + ((listp box) (hfy-box-to-style box) )) )) + +(defun hfy-decor (tag val) + "Derive CSS text-decoration specifiers from various emacs font attributes." + (list + (cond + ((string= tag ":underline" ) (cons "text-decoration" "underline" )) + ((string= tag ":overline" ) (cons "text-decoration" "overline" )) + ((string= tag ":strike-through") (cons "text-decoration" "line-through")))) + ) + +;; construct an assoc of (css-tag-name . css-tag-value) pairs +;; from a face or assoc of face attributes: +(defun hfy-face-to-style-i (fn) + "The guts of `hfy-face-to-style': FN should be a `defface' +font specification, as returned by `face-attr-construct'. Note that +this function does not get font-sizes right if they are based on +inherited modifiers (via the :inherit) attribute, and any other modifiers +that are cumulative if they appear multiple times need to be merged by the +user - `hfy-uniq-styles' should do this. (It currently only handles +font-size)." + ;;(message "-- (%s %S)" 'hfy-face-to-style-i fn) + (if fn + (let ((key (car fn)) + (val (cadr fn)) + (next (cddr fn)) + (that nil) + (this nil) + (parent nil)) + (setq + this + (cond + ((string= key ":family" ) (hfy-family val)) + ((string= key ":width" ) (hfy-width val)) + ((string= key ":weight" ) (hfy-weight val)) + ((string= key ":slant" ) (hfy-slant val)) + ((string= key ":foreground") (hfy-colour val)) + ((string= key ":background") (hfy-bgcol val)) + ((string= key ":box" ) (hfy-box val)) + ((string= key ":height" ) (hfy-size val)) + ((and (string= key ":underline" ) val) (hfy-decor key val)) + ((and (string= key ":overline" ) val) (hfy-decor key val)) + ((and (string= key ":strike-through") val) (hfy-decor key val)) + ((and (string= key ":bold" ) val) (hfy-weight 'bold)) + ((and (string= key ":italic" ) val) (hfy-slant 'italic)))) + (setq that (hfy-face-to-style-i next)) + (if (string= key ":inherit") + (setq parent (hfy-face-to-style-i (face-attr-construct val)))) + (nconc this that parent) ) ) ) + +(defun hfy-size-to-int (spec) + "Convert SPEC, a css font-size specifier, back to an emacs :height attribute +value. Used while merging multiple font-size attributes." + (list + (if (string-match "\\([[:digit:]]+\\)\\(%\\|pt\\)" spec) + (cond + ((string= "%" (match-string 2 spec)) + (/ (string-to-int (match-string 1 spec)) 100.0)) + ((string= "pt" (match-string 2 spec)) + (* (string-to-int (match-string 1 spec)) 10)) ) + (string-to-number spec))) ) + +;; size is different, in that in order to get it right at all, +;; we have to trawl the inheritance path, accumulating modifiers, +;; _until_ we get to an absolute (pt) specifier, then combine the lot +(defun hfy-uniq-styles (style) + "Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge +any multiple attributes appropriately. Currently only font-size is merged +down to a single occurrence - others may need special handling, but I +haven\'t encountered them yet. Returns a `hfy-style-assoc'." + (let ((n 0) + (m (list 1)) + (x nil) + (r nil)) + (mapcar + (lambda (css) + (if (string= (car css) "font-size") + (progn + ;;(message "- [%S]" css) + (if (not x) (setq m (nconc m (hfy-size-to-int (cdr css))))) + (if (string-match "pt" (cdr css)) (setq x t))) + ;;(message "+ [%S]" css) + (setq r (nconc r (list css))))) style) + ;;(message "= [%S]" r) + ;;(message "* [%S]%s" m (if x ".pt" ".%")) + (setq n (apply '* m)) + (nconc r (hfy-size (if x (round n) (* n 1.0)))) r)) + +(defun hfy-face-to-style (fn) + "Take FN, a font or `defface' style font specification, +\(as returned by `face-attr-construct'\) and return a `hfy-style-assoc'. + +See also: `hfy-face-to-style-i', `hfy-uniq-styles'." + (let ((face-def (if (facep fn) (face-attr-construct fn) fn)) + (final-style nil)) + (setq final-style (hfy-uniq-styles (hfy-face-to-style-i face-def))) + (if (not (assoc "text-decoration" final-style)) + (progn + (setq final-style + (nconc final-style '(("text-decoration"."none")))))) + final-style)) + +;; strip redundant bits from a name. Technically, this could result in +;; a collision, but it is pretty unlikely - will fix later... +(defun hfy-css-name (fn) + "Strip some of the boring bits from a font-name and return a css style name." + (let ((face-name (format "%s" fn))) + (if (or (string-match "font-lock-\\(.*\\)" face-name) + (string-match "cperl-\\(.*\\)" face-name) + (string-match "[Ii]nfo-\\(.*\\)" face-name)) + (progn (setq face-name (match-string 1 face-name)) + (if (string-match "\\(.*\\)-face" face-name) + (setq face-name (match-string 1 face-name))) + face-name) + face-name)) ) + +;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs +;; from a face: +(defun hfy-face-to-css (fn) + "Take FN, a font or `defface' specification \(cf. `face-attr-construct'\) +and return a CSS style specification. + +See also: `hfy-face-to-style'" + (let ((css-list nil) + (css-text nil) + (style nil) + (seen nil)) + (setq css-list (hfy-face-to-style fn)) + + (setq css-text + (nconc + (mapcar + (lambda (E) + (if (car E) + (if (not (member (car E) seen)) + (progn + (setq seen (cons (car E) seen)) + (format " %s: %s; " (car E) (cdr E)))))) css-list))) + ;;(message "seen :: %S" seen) + (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) + +;; extract a face from a list of char properties, if there is one: +(defun hfy-p-to-face (props) + "Given PROPS, a list of text-properties, return the value of the face +property, or nil." + (if props + (if (string= (car props) "face") + (if (listp (cadr props)) (car (cadr props)) (cadr props)) + (hfy-p-to-face (cddr props))) + nil)) + +(defun hfy-face-at (p) + "Find face in effect at point P" + (hfy-p-to-face (text-properties-at p))) + +;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements: +(defun hfy-compile-stylesheet () + "Trawl the current buffer, construct an return a `hfy-sheet-assoc'." + (let ((pt (point-min)) + (fn nil) + (css nil) + (style nil)) + (save-excursion + (goto-char pt) + (while (< pt (point-max)) + (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style))) + (setq style (cons (cons fn (hfy-face-to-css fn)) style))) + (setq pt (next-char-property-change pt))) ) + style) ) + +;; remember to generate 'synthetic' </span> entries - +;; emacs copes by just having a stack of styles in effect +;; and only using the top one: html has a more simplistic approach - +;; we have to explicitly end a style, there's no way of temporarily +;; overriding it w. another one... (afaik) +(defun hfy-compile-face-map () + "Compile and return a `hfy-facemap-assoc' for the current buffer." + (let ((pt (point-min)) + (fn nil) + (map nil) + (last-tag nil)) ;; t if the last tag-point was a span-start + ;; nil if it was a span-stop + (save-excursion + (goto-char pt) + (while (< pt (point-max)) + (if (setq fn (hfy-face-at pt)) + (progn (if last-tag (setq map (cons (cons pt 'end) map))) + (setq map (cons (cons pt fn) map)) + (setq last-tag t)) + (setq map (cons (cons pt 'end) map)) + (setq last-tag nil)) + (setq pt (next-char-property-change pt)))) + map) ) + +;; generate a buffer to hold the output. Should make this safer, really... +(defun hfy-buffer () (get-buffer-create (concat (buffer-name) hfy-extn))) + +;; get a css style name for a face from the style: +(defun hfy-lookup (face style) (cadr (assoc face style))) + +;; barf up the inline css stylesheet +(defun hfy-sprintf-stylesheet (css file) + (concat + (apply + 'concat + (funcall hfy-page-header file) + "<style type=\"text/css\"><!-- \n" + (mapcar (lambda (style) + (format "span.%s %s\n span.%s a %s\n" + (cadr style) (cddr style) + (cadr style) (cddr style))) css)) + " --></style>\n\n<pre>\n") ) + +;; tag all the dangerous characters we want to escape +;; (ie any "<> chars we _didn't_ put there explicitly for css markup) +(defun hfy-html-enkludge-buffer () + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\\(\"\\|<\\|>\\)" nil t) + (put-text-property (match-beginning 0) (point) 'hfy-quoteme t) + ) + ) + ) + +;; dangerous char -> &entity; +(defun hfy-html-quote (string) + (cadr (assoc string '(("\"" """) + ("<" "<" ) + (">" ">" )))) ) + +;; actually entity-ise dangerous chars. +;; note that we can't do this until _after_ we have inserted the css +;; markup, since we use a position-based map to insert this, and if we +;; enter any other text before we do this, we'd have to track another +;; map of offsets, which would be tedious... +(defun hfy-html-dekludge-buffer () + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\\(\"\\|<\\|>\\)" nil t) + (if (get-text-property (match-beginning 0) 'hfy-quoteme) + (replace-match (hfy-html-quote (match-string 1))) + ) + ) + ) + ) + +;; do it: +(defun htmlfontify-buffer (&optional srcdir file) + "Create a new buffer, named for the current buffer + a .html extension, +containing an inline css-stylesheet and formatted css-markup html that +reproduces the look of the current emacs buffer as closely as possible. + +Dangerous characters in the existing buffer are turned into html entities, +so you should even be able to do html-within-html fontified display. + +If the SRCDIR and FILE arguments are set, lookup etags derived entries +in the `hfy-tags-cache' and add html anchors and hyperlinks as appropriate" + (interactive) + (let ((in-style nil) + (html-buffer (hfy-buffer )) + (css-sheet (hfy-compile-stylesheet)) + (css-map (hfy-compile-face-map ))) + ;; copy the buffer, including fontification, and switch to it: + (copy-to-buffer html-buffer (point-min) (point-max)) + (set-buffer html-buffer) + ;; at this point, html-buffer retains the fontification of the parent: + ;; ##################################################################### + ;; if we are in etags mode, add properties to mark the anchors and links + (if (and srcdir file) + (progn + (hfy-mark-tags-this-file srcdir file) ;; mark anchors + (hfy-mark-tags-other-file srcdir file))) ;; mark links + ;; ##################################################################### + ;; mark the 'dangerous' characters + (hfy-html-enkludge-buffer) + ;; trawl the position-based face-map, inserting span tags as we go + ;; note that we cannot change any character positions before this point + ;; or we will invalidate the map: + ;; NB: This also means we have to trawl the map in descending file-offset + ;; order, obviously. + (mapcar + (lambda (point-face) + (let ((pt (car point-face)) + (fn (cdr point-face))) + (goto-char pt) + (if (eq 'end fn) (insert "</span>") + (insert (format "<span class=\"%s\">" + (hfy-lookup fn css-sheet))) ))) css-map) + ;; ##################################################################### + (if (and srcdir file) + (let ((pt nil) + (pr nil) + (x nil)) + (progn + (setq pt (point-min)) + (while (setq pt (next-single-property-change pt 'hfy-anchor)) + (if (setq pr (get-text-property pt 'hfy-anchor)) + (progn (goto-char pt) + ;;(message "%s :: %s <- %s" pt file pr) + (remove-text-properties pt (1+ pt) '(hfy-anchor nil)) + (insert (concat "<a name=\"" pr "\"></a>"))))) + (setq pt (point-min)) + (while (setq pt (next-single-property-change pt 'hfy-link)) + (if (setq pr (get-text-property pt 'hfy-link)) + (progn (goto-char pt) + ;;(setq pr (hfy-p-to-href pr)) ;; IMPLEMENTME + (remove-text-properties pt (1+ pt) '(hfy-link nil)) + (insert (format "<a href=\"%s\">" pr))))) + (setq pt (point-min)) + (while (setq pt (next-single-property-change pt 'hfy-endl)) + (if (get-text-property pt 'hfy-endl) + (progn (goto-char pt) + (remove-text-properties pt (1+ pt) '(hfy-endl nil)) + (insert "</a>")))) + ) ) ) + ;; ##################################################################### + ;; transform the dangerous chars. This changes character positions + ;; since entities have > char length. + ;; note that this deletes the dangerous characters, and therefore + ;; destroys any ptoperties they may contain (such as 'hfy-endl), + ;; so we have to do this after we use said properties: + (hfy-html-dekludge-buffer) + ;; insert the stylesheet at the top: + (goto-char (point-min)) + (insert (hfy-sprintf-stylesheet css-sheet file)) + (goto-char (point-max)) + (insert "\n</pre>\n") + (insert (funcall hfy-page-footer file)) + ;; display the html buffer, if interactive: + (if (interactive-p) (switch-to-buffer html-buffer)) + html-buffer) + ) + +;; recursive file listing +(defun hfy-list-files (directory) + (cd directory) + (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F)) + (split-string (shell-command-to-string hfy-find-cmd))) ) + +;; strip the filename off, return a directiry name +;; not a particularly thorough implementaion, but it will be +;; fed pretty carefully, so it should be Ok: +(defun hfy-dirname (file) + (let ((f (directory-file-name file))) + (and (string-match "^\\(.*\\)/" f) (match-string 1 f)))) + +;; create a directory, cf mkdir -p +(defun hfy-make-directory (dir) + (if (file-exists-p dir) + (if (file-directory-p dir) t) + (make-directory dir t))) + +;; open a file, check fontification, if fontified, write a fontified copy +;; to the destination directory, otherwise just copy the file: +(defun hfy-copy-and-fontify-file (srcdir dstdir file) + (let ((target nil) + (source nil) + (html nil)) + (cd srcdir) + (save-excursion + (setq source (find-file-noselect file)) + (set-buffer source) + (setq target (concat dstdir "/" file)) + (hfy-make-directory (hfy-dirname target)) + (if (and font-lock-mode font-lock-fontified) + (progn (setq html (htmlfontify-buffer srcdir file)) + (set-buffer html) + (write-file (concat target hfy-extn)) + (kill-buffer html)) + ;;(message "(copy-file %S %S)" (buffer-file-name source) target) + (copy-file (buffer-file-name source) target 'overwrite)) + (kill-buffer source)) + ) + ) + +;; what line are we on? +(defun hfy-line-number () + (let ((opoint (point)) start) + (save-excursion + (goto-char (point-min)) + (forward-line 0) + (setq start (point)) + (goto-char opoint) + (forward-line 0) + (1+ (count-lines 1 (point)))))) + +;; list of tags in file in srcdir +(defun hfy-tags-for-file (srcdir file) + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (cache-hash nil) + (tag-list nil)) + (if (setq cache-hash (cadr cache-entry)) + (maphash + (lambda (K V) + (if (assoc file V) + (setq tag-list (cons K tag-list)))) cache-hash)) + tag-list)) + +(defconst etags-tag-regex (concat ".*" + "\x7f" "\\(.+\\)" + "\x01" "\\([[:digit:]]+\\)" + "," "\\([[:digit:]]+\\)$")) + +;; mark the tags native to this file for anchors +(defun hfy-mark-tags-this-file (srcdir file) + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (cache-hash nil)) + (if (setq cache-hash (cadr cache-entry)) + (mapcar + (lambda (TAG) + (let* ((V (gethash TAG cache-hash)) + (line (cadr (assoc file V) )) + (chr (car (cddr (assoc file V)))) + (link (concat TAG "." (format "%d" line)))) + (put-text-property (1+ chr) (+ 2 chr) 'hfy-anchor link))) + (hfy-tags-for-file srcdir file))))) + + +(defun hfy-relstub (file &optional start) + (let ((c "")) + (while (setq start (string-match "/" file start)) + (setq start (1+ start)) (setq c (concat c "../"))) + c)) + +(defun hfy-href-stub (this-file def-files) + (concat + (hfy-relstub this-file) + (if (= 1 (length def-files)) (car def-files) hfy-index-file))) + +(defun hfy-href (this-file def-files tag tag-map) + (concat + (hfy-href-stub this-file def-files) + (or hfy-link-extn hfy-extn) "#" tag ;;(.src -> .html) + (if (= 1 (length def-files)) + (concat "." (format "%d" (cadr (assoc (car def-files) tag-map)))))) ) + +;; mark all tags for hyperlinking, except the tags at +;; their own points of definition, iyswim: +(defun hfy-mark-tags-other-file (srcdir file) + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (list-cache (assoc srcdir hfy-tags-sortl)) + (cache-hash nil) + (tags-list nil) + (case-fold-search nil)) + (if (and (setq cache-hash (cadr cache-entry)) + (setq tags-list (cadr list-cache ))) + (mapcar + (lambda (TAG) + (let* ((start nil ) + (stop nil ) + (href nil ) + (tag-map (gethash TAG cache-hash)) + (tag-files (mapcar (lambda (X) (car X)) tag-map)) + ) + (goto-char (point-min)) + (while (word-search-forward TAG nil 'NOERROR) + (setq start (match-beginning 0)) + (setq stop (point)) + (if (or (text-property-any start (1+ stop) 'hfy-linkp t) + (and (member file tag-files) ;; tag defined in this file + (= (hfy-line-number) ;; and we're on that line + (cadr (assoc file tag-map))))) + ;; this is already marked for linking, + ;; OR we are at one of the tag's points of definition + nil + ;; mark the link. link to the index if the tag has > 1 def + ;; add the line number to the #name if it does not: + (setq href (hfy-href file tag-files TAG tag-map)) + (put-text-property start (1+ start) 'hfy-link href) + (put-text-property stop (1+ stop ) 'hfy-endl t ) + (put-text-property start (1+ stop ) 'hfy-linkp t )) ))) + tags-list) ))) + +;; cache the #(tag => file line point) entries for files under srcdir +;; and cache the descending sorted list of tags in the relevant alist, +;; also keyed by srcdir: +(defun hfy-load-tags-cache (srcdir) + (let ((etags-buffer (get-buffer-create "*hfy-etags*")) + (cache-entry (assoc srcdir hfy-tags-cache)) + (tlist-cache (assoc srcdir hfy-tags-sortl)) + (cache-hash nil) + (tags-list nil) + (hash-entry nil) + (tag-string nil) + (tag-line nil) + (tag-point nil) + (etags-file nil)) + (cd srcdir) + (if cache-entry (setq cache-hash (cadr cache-entry)) + (setq cache-hash (make-hash-table :test 'equal)) + (setq hfy-tags-cache (list (list srcdir cache-hash) hfy-tags-cache))) + (shell-command hfy-etags-cmd etags-buffer) + (clrhash cache-hash) + ;; cache the TAG => ((file line point) (file line point) ... ) + ;; entries: + (save-excursion + (set-buffer etags-buffer) + (goto-char (point-min)) + (while (and (looking-at "^\x0c") (= 0 (forward-line 1))) + (if (and (looking-at "^\\(.+\\),\\([[:digit:]]+\\)$") + (= 0 (forward-line 1))) + (progn + (setq etags-file (match-string 1)) + (while (and (looking-at etags-tag-regex) (= 0 (forward-line 1))) + (setq tag-string (match-string 1)) + (setq tag-line (string-to-int (match-string 2))) + (setq tag-point (string-to-int (match-string 3))) + (setq hash-entry (gethash tag-string cache-hash)) + (setq hash-entry + (cons (list etags-file tag-line tag-point) hash-entry)) + (puthash tag-string hash-entry cache-hash)) )))) + ;; cache a list of tags in descending length order: + (maphash (lambda (K V) (setq tags-list (cons K tags-list))) cache-hash) + (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A))))) + (if tlist-cache (setcar (cdr tlist-cache) tags-list) + (setq hfy-tags-sortl (cons (list srcdir tags-list) hfy-tags-sortl))) )) + +(defun hfy-write-index (srcdir dstdir) + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (cache-hash nil) + (tag-list nil) + (index-file (concat hfy-index-file hfy-extn)) + (index-buf nil) + ) + (if (and cache-entry + (setq cache-hash (cadr cache-entry)) + (setq index-buf (find-file-noselect index-file))) + (progn + (maphash (lambda (K V) (setq tag-list (cons K tag-list))) cache-hash) + (setq tag-list (sort tag-list 'string<)) + (set-buffer index-buf) + (erase-buffer) + (insert (funcall hfy-page-header hfy-index-file)) + (insert "<pre>\n") + (mapcar + (lambda (TAG) + (insert (format "<a name=\"%s\"></a>" TAG)) + (mapcar + (lambda (DEF) + (let ((file (car DEF)) + (line (cadr DEF))) + (insert + (format "<a href=\"%s%s#%s.%d\">%s (%s,%d)</a>\n" + file + (or hfy-link-extn hfy-extn) ;;(.src -> .html) + TAG + line + TAG + file + line)))) (gethash TAG cache-hash))) tag-list) + (insert "</pre>\n") + (insert (funcall hfy-page-footer hfy-index-file)) + (cd dstdir) + (write-file index-file)) + ) + ) + ) + +(defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext) + (let ((source-files "SETME: list of source files, relative to srcdir") + (font-lock-support-mode 'fast-lock-mode) + (hfy-extn (or f-ext ".html")) + (hfy-link-extn (or l-ext ".html"))) + (hfy-make-directory dstdir) + (setq source-files (hfy-list-files srcdir)) + (hfy-load-tags-cache srcdir) + (mapcar (lambda (file) + (hfy-copy-and-fontify-file srcdir dstdir file)) source-files) + (hfy-write-index srcdir dstdir)) ) + +;; ########################################################################## +;; this is for part of the build system for rtfm.etla.org: +;; it's not really part of htmlfontify - but it's an example +;; of how to use it: + +(defun rtfm-build-page-header (file) + (format "#define TEMPLATE red+black.html +#define DEBUG 1 +#include <build/menu-dirlist|> + +html-css-url := /css/red+black.css +title := rtfm.etla.org ( SQL / dbishell / src/%s ) +bodytag := +head := +main-title := rtfm / SQL / dbishell / src/%s + +main-content <=MAIN_CONTENT;\n" file file)) + +(defun rtfm-build-page-footer (file) "\nMAIN_CONTENT\n") + +(defun rtfm-build-source-docs (srcdir destdir) + (let ((hfy-page-header 'rtfm-build-page-header) + (hfy-page-footer 'rtfm-build-page-footer) + (hfy-index-file "index")) + (htmlfontify-copy-and-link-dir srcdir destdir ".src" ".html"))) + +;; TLF diff --git a/emacs-lisp/modes/linum.el b/emacs-lisp/modes/linum.el new file mode 100644 index 0000000..792aa8a --- /dev/null +++ b/emacs-lisp/modes/linum.el @@ -0,0 +1,204 @@ +;;; linum.el --- Display line numbers to the left of buffers + +;; Copyright (C) 2007, 2008 Markus Triska + +;; Author: Markus Triska <markus.triska@gmx.at> +;; Keywords: convenience + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Display line numbers for the current buffer. Copy linum.el to your +;; load-path and add to your .emacs: + +;; (require 'linum) + +;; Then toggle display of line numbers with M-x linum-mode. To enable +;; line numbering in all buffers, use M-x global-linum-mode. + +;;; Code: + +(defconst linum-version "0.9wza") + +(defvar linum-overlays nil "Overlays used in this buffer.") +(defvar linum-available nil "Overlays available for reuse.") +(defvar linum-before-numbering-hook nil + "Functions run in each buffer before line numbering starts.") + +(mapc #'make-variable-buffer-local '(linum-overlays linum-available)) + +(defgroup linum nil + "Show line numbers to the left of buffers" + :group 'convenience) + +;;;###autoload +(defcustom linum-format 'dynamic + "Format used to display line numbers. Either a format string +like \"%7d\", 'dynamic to adapt the width as needed, or a +function that is called with a line number as its argument and +should evaluate to a string to be shown on that line. See also +`linum-before-numbering-hook'." + :group 'linum + :type 'sexp) + +(defface linum + '((t :inherit (shadow default))) + "Face for displaying line numbers in the display margin." + :group 'linum) + +(defcustom linum-eager t + "Whether line numbers should be updated after each command. +The conservative setting `nil' might miss some buffer changes, +and you have to scroll or press C-l to update the numbers." + :group 'linum + :type 'boolean) + +(defcustom linum-delay nil + "Delay updates to give Emacs a chance for other changes." + :group 'linum + :type 'boolean) + +;;;###autoload +(define-minor-mode linum-mode + "Toggle display of line numbers in the left marginal area." + :lighter "" ; for desktop.el + (if linum-mode + (progn + (if linum-eager + (add-hook 'post-command-hook (if linum-delay + 'linum-schedule + 'linum-update-current) nil t) + (add-hook 'after-change-functions 'linum-after-change nil t)) + (add-hook 'window-scroll-functions 'linum-after-scroll nil t) + ;; mistake in Emacs: window-size-change-functions cannot be local + (add-hook 'window-size-change-functions 'linum-after-size) + (add-hook 'change-major-mode-hook 'linum-delete-overlays nil t) + (add-hook 'window-configuration-change-hook + 'linum-after-config nil t) + (linum-update-current)) + (remove-hook 'post-command-hook 'linum-update-current t) + (remove-hook 'post-command-hook 'linum-schedule t) + (remove-hook 'window-size-change-functions 'linum-after-size) + (remove-hook 'window-scroll-functions 'linum-after-scroll t) + (remove-hook 'after-change-functions 'linum-after-change t) + (remove-hook 'window-configuration-change-hook 'linum-after-config t) + (remove-hook 'change-major-mode-hook 'linum-delete-overlays t) + (linum-delete-overlays))) + +;;;###autoload +(define-globalized-minor-mode global-linum-mode linum-mode linum-on) + +(defun linum-on () + (unless (minibufferp) + (linum-mode 1))) + +(defun linum-delete-overlays () + "Delete all overlays displaying line numbers for this buffer." + (mapc #'delete-overlay linum-overlays) + (setq linum-overlays nil) + (dolist (w (get-buffer-window-list (current-buffer) nil t)) + (set-window-margins w 0))) + +(defun linum-update-current () + "Update line numbers for the current buffer." + (linum-update (current-buffer))) + +(defun linum-update (buffer) + "Update line numbers for all windows displaying BUFFER." + (with-current-buffer buffer + (when linum-mode + (setq linum-available linum-overlays) + (setq linum-overlays nil) + (save-excursion + (mapc #'linum-update-window + (get-buffer-window-list buffer nil 'visible))) + (mapc #'delete-overlay linum-available) + (setq linum-available nil)))) + +(defun linum-update-window (win) + "Update line numbers for the portion visible in window WIN." + (goto-char (window-start win)) + (let* ((line (line-number-at-pos)) + (limit (window-end win t)) + ;; set empty-line-at-eob flag + (empty-line-at-eob (or (equal ?\n (char-before (point-max))) + (equal (point-min) (point-max)))) + ;; we will automatically number the line at eob if it's not empty + ;; (so we'll say it's already done) + (numbered-line-at-eob (not empty-line-at-eob)) + (fmt (cond ((stringp linum-format) linum-format) + ((eq linum-format 'dynamic) + (let* ((c (count-lines (point-min) (point-max))) + (w (length (number-to-string + (+ c (if empty-line-at-eob 1 0)))))) + (concat "%" (number-to-string w) "d"))))) + (width 0)) + (run-hooks 'linum-before-numbering-hook) + ;; Create an overlay (or reuse an existing one) for each + ;; line visible in this window, if necessary. + ;; stop if point>limit, or if eobp and numbered-line-at-eob + (while (and (not (and (eobp) numbered-line-at-eob)) (<= (point) limit)) + (let* ((str (if fmt + (propertize (format fmt line) 'face 'linum) + (funcall linum-format line))) + (visited (catch 'visited + (dolist (o (overlays-in (point) (point))) + (when (string= (overlay-get o 'linum-str) str) + (unless (memq o linum-overlays) + (push o linum-overlays)) + (setq linum-available (delete o linum-available)) + (throw 'visited t)))))) + (setq width (max width (length str))) + (unless visited + (let ((ov (if (null linum-available) + (make-overlay (point) (point)) + (move-overlay (pop linum-available) (point) (point))))) + (push ov linum-overlays) + (overlay-put ov 'before-string + (propertize " " 'display `((margin left-margin) ,str))) + (overlay-put ov 'linum-str str)))) + ;; before moving forward, if we're already at eob + (if (eobp) + ;; then we've numbered the empty line + (setq numbered-line-at-eob t)) + (forward-line) + (setq line (1+ line))) + (set-window-margins win width))) + +(defun linum-after-change (beg end len) + ;; update overlays on deletions, and after newlines are inserted + (when (or (= beg end) + (= end (point-max)) + ;; TODO: use string-match-p with CVS or new release + (string-match "\n" (buffer-substring-no-properties beg end))) + (linum-update-current))) + +(defun linum-after-scroll (win start) + (linum-update (window-buffer win))) + +(defun linum-after-size (frame) + (linum-after-config)) + +(defun linum-schedule () + ;; schedule an update; the delay gives Emacs a chance for display changes + (run-with-idle-timer 0 nil #'linum-update-current)) + +(defun linum-after-config () + (walk-windows (lambda (w) (linum-update (window-buffer w))) nil 'visible)) + +(provide 'linum) +;;; linum.el ends here diff --git a/emacs-lisp/modes/lua.el b/emacs-lisp/modes/lua.el new file mode 100644 index 0000000..725759b --- /dev/null +++ b/emacs-lisp/modes/lua.el @@ -0,0 +1,1096 @@ +;;; lua-mode.el --- a major-mode for editing lua scripts + +;; FIXME: Update this version number and date +;; $Id: lua-mode.el,v 1.26 2001/07/08 19:06:50 cvogler Exp $ + +;; Copyright (C) 1997, 2001 Free Software Foundation, Inc. + +;; Author: 2001 Christian Vogler <cvogler@gradient.cis.upenn.edu> +;; 1997 Bret Mogilefsky <mogul-lua@gelatinous.com> starting from +;; tcl-mode by Gregor Schmid <schmid@fb3-s7.math.tu-berlin.de> +;; with tons of assistance from +;; Paul Du Bois <pld-lua@gelatinous.com> and +;; Aaron Smith <aaron-lua@gelatinous.com>. + +;; Keywords: languages, processes, tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Special Thanks to Simon Marshall <simonm@mail.esrin.esa.it> for +;; font-lock patches. + +;; Additional font-lock highlighting and indentation tweaks by +;; Adam D. Moss <adam@gimp.org> <aspirin@icculus.org> + +;; This file was written with emacs using Jamie Lokier's folding mode +;; That's what the funny ;;{{{ marks are there for + +;;{{{ Usage + +;; Lua-mode supports c-mode style formatting and sending of +;; lines/regions/files to a lua interpreter. An interpreter (see +;; variable `lua-default-application') will be started if you try to +;; send some code and none is running. You can use the process-buffer +;; (named after the application you chose) as if it were an +;; interactive shell. See the documentation for `comint.el' for +;; details. + +;;}}} +;;{{{ Key-bindings + +;; To see all the keybindings for lua mode, look at `lua-setup-keymap' +;; or start `lua-mode' and type `\C-h m'. +;; The keybindings may seem strange, since I prefer to use them with +;; lua-prefix-key set to nil, but since those keybindings are already used +;; the default for `lua-prefix-key' is `\C-c', which is the conventional +;; prefix for major-mode commands. + +;; You can customise the keybindings either by setting `lua-prefix-key' +;; or by putting the following in your .emacs +;; (setq lua-mode-map (make-sparse-keymap)) +;; and +;; (define-key lua-mode-map <your-key> <function>) +;; for all the functions you need. + +;;}}} +;;{{{ Variables + +;; You may want to customize the following variables: +;; +;; lua-indent-level +;; lua_always-show +;; lua-mode-map +;; lua-prefix-key +;; lua-mode-hook +;; lua-default-application +;; lua-default-command-switches + +;;}}} + +;;; Code: +(defconst lua-using-xemacs (string-match "XEmacs" emacs-version) + "Nil unless using XEmacs).") + +;; We need that ! +(require 'comint) + +;;{{{ variables + +(defvar lua-default-application "/home/swt/swt/oose/lua/bin/lua" + "Default application to run in lua subprocess.") + +(defvar lua-default-command-switches nil + "Command switches for `lua-default-application'. +Should be a list of strings.") + +(defvar lua-process nil + "The active lua subprocess corresponding to current buffer.") + +(defvar lua-process-buffer nil + "Buffer used for communication with lua subprocess for current buffer.") + +(defvar lua-always-show t + "*Non-nil means display lua-process-buffer after sending a command.") + +(defvar lua-mode-map nil + "Keymap used with lua-mode.") + +(defvar lua-prefix-key "\C-c" + "Prefix for all lua-mode commands.") + +(defvar lua-mode-hook nil + "Hooks called when lua mode fires up.") + +(defvar lua-region-start (make-marker) + "Start of special region for lua communication.") + +(defvar lua-region-end (make-marker) + "End of special region for lua communication.") + +(defvar lua-indent-level 3 + "Amount by which lua subexpressions are indented.") + +(defvar lua-mode-menu (make-sparse-keymap "Lua") + "Keymap for lua-mode's menu.") + +(defvar lua-font-lock-keywords + (eval-when-compile + (list + ;; + ;; Function name declarations. + '("^[ \t]*\\<\\(\\(local[ \t]+\\)?function\\)\\>[ \t]+\\(\\(\\sw:\\|\\sw\\.\\|\\sw_\\|\\sw\\)+\\)" + (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) + + ; Highlight multi-line comment blocks; since font-lock-mode doesn't + ; claim to handle the highlighting of multi-line expressions elegantly + ; this works best with lazy-lock-mode if your Emacs supports it, e.g. + ; try (setq font-lock-support-mode 'lazy-lock-mode) in your ~/.emacs + + ;; Multi-line comment blocks. + `("--.*\\(\\[\\[\\(\\]?[^]]\\)*\\]\\]\\)" + (1 font-lock-comment-face t)) + + ;; + ;; Keywords. + ;; (concat "\\<" + ;; (regexp-opt '("and" "break" "do" "else" "elseif" "end" "false" + ;; "for" "function" "if" "in" "local" "nil" "not" + ;; "or" "repeat" "return" "then" "true" "until" + ;; "while") t) + ;; "\\>") + + ; Insert expanded regexp-opt here for the benefit of those who + ; don't have regexp-opt available. + + "\\<\\(and\\|break\\|do\\|e\\(lse\\(if\\)?\\|nd\\)\\|f\\(alse\\|or\\|unction\\)\\|i[fn]\\|local\\|n\\(il\\|ot\\)\\|or\\|re\\(peat\\|turn\\)\\|t\\(hen\\|rue\\)\\|until\\|while\\)\\>" + + "Default expressions to highlight in Lua mode."))) + +(defvar lua-imenu-generic-expression +; '((nil "^[ \t]*function[ \t]+\\(\\(\\s_\\|\\sw\\)+\\)" 1)) ; Original + '((nil "^[ \t]*function[ \t]+\\(\\(\\sw:\\|\\sw_\\|\\sw\\.\\|\\sw\\)+\\)" 1)) ; Original + "Imenu generic expression for lua-mode. See `imenu-generic-expression'.") + +(define-abbrev-table 'lua-mode-abbrev-table + '( + ("end" "end" lua-indent-line 0) + ("else" "else" lua-indent-line 0) + ("elseif" "elseif" lua-indent-line 0) + )) + +(defconst lua-indent-whitespace " \t" + "Character set that constitutes whitespace for indentation in lua.") + +;;}}} +;;{{{ lua-mode + +;;;###autoload +(defun lua-mode () + "Major mode for editing lua scripts. +The following keys are bound: +\\{lua-mode-map} +" + (interactive) + (let ((switches nil) + s) + (kill-all-local-variables) + (setq major-mode 'lua-mode) + (setq mode-name "Lua") + (set (make-local-variable 'lua-process) nil) + (set (make-local-variable 'lua-process-buffer) nil) + (make-local-variable 'lua-default-command-switches) + (set (make-local-variable 'indent-line-function) 'lua-indent-line) + (set (make-local-variable 'comment-start) "--") + (set (make-local-variable 'comment-start-skip) "--") + (set (make-local-variable 'font-lock-defaults) + '(lua-font-lock-keywords nil nil ((?_ . "w")))) + (set (make-local-variable 'imenu-generic-expression) + lua-imenu-generic-expression) + (setq local-abbrev-table lua-mode-abbrev-table) + (abbrev-mode 1) + (make-local-variable 'lua-default-eval) + (or lua-mode-map + (lua-setup-keymap)) + (use-local-map lua-mode-map) + (set-syntax-table (copy-syntax-table)) + (modify-syntax-entry ?+ ".") + (modify-syntax-entry ?- ". 12") + (modify-syntax-entry ?* ".") + (modify-syntax-entry ?/ ".") + (modify-syntax-entry ?^ ".") + (modify-syntax-entry ?. ".") + (modify-syntax-entry ?> ".") + (modify-syntax-entry ?< ".") + (modify-syntax-entry ?= ".") + (modify-syntax-entry ?~ ".") + (modify-syntax-entry ?\n ">") + (modify-syntax-entry ?\' "\"") + (modify-syntax-entry ?\" "\"") + ;; _ needs to be part of a word, or the regular expressions will + ;; incorrectly regognize end_ to be matched by "\\<end\\>"! + (modify-syntax-entry ?_ "w") + (if (and lua-using-xemacs + (featurep 'menubar) + current-menubar + (not (assoc "Lua" current-menubar))) + (progn + (set-buffer-menubar (copy-sequence current-menubar)) + (add-menu nil "Lua" lua-xemacs-menu))) + ;; Append Lua menu to popup menu for XEmacs. + (if (and lua-using-xemacs (boundp 'mode-popup-menu)) + (setq mode-popup-menu + (cons (concat mode-name " Mode Commands") lua-xemacs-menu))) + (run-hooks 'lua-mode-hook))) + +;;}}} +;;{{{ lua-setup-keymap + +(defun lua-setup-keymap () + "Set up keymap for lua mode. +If the variable `lua-prefix-key' is nil, the bindings go directly +to `lua-mode-map', otherwise they are prefixed with `lua-prefix-key'." + (setq lua-mode-map (make-sparse-keymap)) + (define-key lua-mode-map [menu-bar lua-mode] + (cons "Lua" lua-mode-menu)) + (define-key lua-mode-map "}" 'lua-electric-match) + (define-key lua-mode-map "]" 'lua-electric-match) + (define-key lua-mode-map ")" 'lua-electric-match) + (let ((map (if lua-prefix-key + (make-sparse-keymap) + lua-mode-map))) + + ;; communication + (define-key map "\M-[" 'lua-beginning-of-proc) + (define-key map "\M-]" 'lua-end-of-proc) + (define-key map "\C-c" 'comment-region) + (if lua-prefix-key + (define-key lua-mode-map lua-prefix-key map)) + )) + +;;}}} +;;{{{ indentation + +;;{{{ lua-electric-match + +(defun lua-electric-match (arg) + "Insert character and adjust indentation." + (interactive "P") + (insert-char last-command-char (prefix-numeric-value arg)) + (lua-indent-line) + (blink-matching-open)) + +;;}}} + +(defun lua-syntax-status () + "Returns the syntactic status of the character after the point." + (parse-partial-sexp (save-excursion (beginning-of-line) (point)) + (point))) + +(defun lua-string-p () + "Returns true if the point is in a string." + (elt (lua-syntax-status) 3)) + +(defun lua-comment-p () + "Returns true if the point is in a comment." + (elt (lua-syntax-status) 4)) + +(defun lua-comment-or-string-p () + "Returns true if the point is in a comment or string." + (let ((parse-result (lua-syntax-status))) + (or (elt parse-result 3) (elt parse-result 4)))) + + +;;{{{ lua-indent-line + +(defun lua-indent-line () + "Indent current line as lua code. +Return the amount the indentation changed by." + (let ((indent (max 0 (- (lua-calculate-indentation nil) + (lua-calculate-indentation-left-shift)))) + beg shift-amt + (case-fold-search nil) + (pos (- (point-max) (point)))) + (beginning-of-line) + (setq beg (point)) + (skip-chars-forward lua-indent-whitespace) + (setq shift-amt (- indent (current-column))) + (when (not (zerop shift-amt)) + (delete-region beg (point)) + (indent-to indent)) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + shift-amt + indent)) + +;;}}} + + + +(defun lua-find-regexp (direction regexp &optional limit ignore-p) + "Searches for a regular expression in the direction specified. +Direction is one of 'forward and 'backward. +By default, matches in comments and strings are ignored, but what to ignore is +configurable by specifying ignore-p. If the regexp is found, returns point +position, nil otherwise. +ignore-p returns true if the match at the current point position should be +ignored, nil otherwise." + (let ((ignore-func (or ignore-p 'lua-comment-or-string-p)) + (search-func (if (eq direction 'forward) + 're-search-forward 're-search-backward)) + (case-fold-search nil)) + (catch 'found + (while (funcall search-func regexp limit t) + (if (not (funcall ignore-func)) + (throw 'found (point))))))) + + +;;{{{ lua-backwards-to-block-begin-or-end + +(defconst lua-block-regexp + (eval-when-compile + ;; This is the code we used to generate the regexp: + (concat + "\\(\\<" + (regexp-opt '("do" "function" "repeat" "then" + "else" "elseif" "end" "until") t) + "\\>\\)\\|" + (regexp-opt '("{" "(" "[" "]" ")" "}") t)) + + )) + +(defun lua-backwards-to-block-begin-or-end () + "Move backwards to nearest block begin or end. Returns nil if not successful." + (interactive) + (lua-find-regexp 'backward lua-block-regexp)) + +;;}}} + +(defconst lua-block-token-alist + ;; The absence of "else" is deliberate. This construct in a way both + ;; opens and closes a block. As a result, it is difficult to handle + ;; cleanly. It is also ambiguous - if we are looking for the match + ;; of "else", should we look backward for "then/elseif" or forward + ;; for "end"? + ;; Maybe later we will find a way to handle it. + '(("do" "\\<end\\>" open) + ("function" "\\<end\\>" open) + ("repeat" "\\<until\\>" open) + ("then" "\\<\\(e\\(lseif\\|nd\\)\\)\\>" open) + ("{" "}" open) + ("[" "]" open) + ("(" ")" open) + ("elseif" "\\<then\\>" close) + ("end" "\\<\\(do\\|function\\|then\\)\\>" close) + ("until" "\\<repeat\\>" close) + ("}" "{" close) + ("]" "\\[" close) + (")" "(" close))) + + +(defun lua-find-matching-token-word (token search-start) + (let* ((token-info (assoc token lua-block-token-alist)) + (match (car (cdr token-info))) + (match-type (car (cdr (cdr token-info)))) + (search-direction (if (eq match-type 'open) 'forward 'backward))) + ;; if we are searching forward from the token at the current point + ;; (i.e. for a closing token), need to step one character forward + ;; first, or the regexp will match the opening token. + (if (eq match-type 'open) (forward-char 1)) + (if search-start (goto-char search-start)) + (catch 'found + (while (lua-find-regexp search-direction lua-indentation-modifier-regexp) + ;; have we found a valid matching token? + (let ((found-token (match-string 0)) + (found-pos (match-beginning 0))) + (if (string-match match found-token) + (throw 'found found-pos)) + ;; no - then there is a nested block. If we were looking for + ;; a block begin token, found-token must be a block end + ;; token; likewise, if we were looking for a block end token, + ;; found-token must be a block begin token, otherwise there + ;; is a grammatical error in the code. + (if (not (and + (eq (car (cdr (cdr (assoc found-token lua-block-token-alist)))) + match-type) + (lua-find-matching-token-word found-token nil))) + (throw 'found nil))))))) + + +(defun lua-goto-matching-block-token (&optional search-start parse-start) + "Find block begion/end token matching the one at the point. +This function moves the point to the token that matches the one +at the current point. Returns the point position of the first character of +the matching token if successful, nil otherwise." + (if parse-start (goto-char parse-start)) + (let ((case-fold-search nil)) + (if (looking-at lua-indentation-modifier-regexp) + (let ((position (lua-find-matching-token-word (match-string 0) + search-start))) + (and position + (goto-char position)))))) + +;; The following may be useful to speed up the search in the future. +; (let ((token-type (char-syntax (string-to-char token-to-match))) +; matching-pos) +; (cond ((eq token-type ?\() +; (setq matching-pos (scan-sexps (point) 1 (current-buffer) t)) +; (when matching-pos (goto-char matching-pos))) + +; ((eq token-type ?\)) +; ;; need to move one char forward, because scan-sexps +; ;; expects the point to be one past the closing parenthesis +; (forward-char 1) +; (setq matching-pos (scan-sexps (point) -1 (current-buffer) t)) +; (when matching-pos (goto-char matching-pos))) + +; (t +; (lua-goto-matching-token-word token-to-match search-start))))))) + + + +(defun lua-goto-matching-block (&optional noreport) + "Go to the keyword balancing the one under the point. +If the point is on a keyword/brace that starts a block, go to the +matching keyword that ends the block, and vice versa." + (interactive) + ;; search backward to the beginning of the keyword if necessary + (if (eq (char-syntax (following-char)) ?w) + (re-search-backward "\\<" nil t)) + (let ((position (lua-goto-matching-block-token))) + (if (and (not position) + (not noreport)) + (error "Not on a block control keyword or brace.") + position))) + + +(defun lua-goto-nonblank-previous-line () + "Puts the point at the first previous line that is not blank. +Returns the point, or nil if it reached the beginning of the buffer" + (catch 'found + (beginning-of-line) + (while t + (if (bobp) (throw 'found nil)) + (forward-char -1) + (beginning-of-line) + (if (not (looking-at "\\s *\\(--.*\\)?$")) (throw 'found (point)))))) + + +(eval-when-compile + (defconst lua-operator-class + "-+*/^.=<>~")) + +(defconst lua-cont-eol-regexp + (eval-when-compile + ;; expression used to generate the regexp + (concat + "\\(\\<" + (regexp-opt '("and" "or" "not" "in" "for" "while" + "local" "function") t) + "\\>\\|" + "\\(^\\|[^" lua-operator-class "]\\)" + (regexp-opt '("+" "-" "*" "/" "^" ".." "==" "=" "<" ">" "<=" ">=" "~=") t) + "\\)" + "\\s *\\=") + + )) + + +(defconst lua-cont-bol-regexp + (eval-when-compile + ;; expression used to generate the regexp + (concat + "\\=\\s *" + "\\(\\<" + (regexp-opt '("and" "or" "not") t) + "\\>\\|" + (regexp-opt '("+" "-" "*" "/" "^" ".." "==" "=" "<" ">" "<=" ">=" "~=") t) + "\\($\\|[^" lua-operator-class "]\\)" + "\\)") + + )) + +(defun lua-last-token-continues-p () + "Returns true if the last token on this line is a continuation token." + (let (line-begin + line-end) + (save-excursion + (beginning-of-line) + (setq line-begin (point)) + (end-of-line) + (setq line-end (point)) + ;; we need to check whether the line ends in a comment and + ;; skip that one. + (while (lua-find-regexp 'backward "-" line-begin 'lua-string-p) + (if (looking-at "--") + (setq line-end (point)))) + (goto-char line-end) + (re-search-backward lua-cont-eol-regexp line-begin t)))) + +(defun lua-first-token-continues-p () + "Returns true if the first token on this line is a continuation token." + (let (line-end) + (save-excursion + (end-of-line) + (setq line-end (point)) + (beginning-of-line) + (re-search-forward lua-cont-bol-regexp line-end t)))) + + +(defun lua-is-continuing-statement-p (&optional parse-start) + "Return nonnil if the line continues a statement. +More specifically, return the point in the line that is continued. +The criteria for a continuing statement are: + +* the last token of the previous line is a continuing op, + OR the first token of the current line is a continuing op + +AND + +* the indentation modifier of the preceding line is nonpositive. + +The latter is sort of a hack, but it is easier to use this criterion, instead +of reducing the indentation when a continued statement also starts a new +block. This is for aesthetic reasons: the indentation should be + +dosomething(d + + e + f + g) + +not + +dosomething(d + + e + f + g)" + (let ((prev-line nil)) + (save-excursion + (if parse-start (goto-char parse-start)) + (save-excursion (setq prev-line (lua-goto-nonblank-previous-line))) + (and prev-line + (or (lua-first-token-continues-p) + (and (goto-char prev-line) + ;; check last token of previous nonblank line + (lua-last-token-continues-p))) + (<= (lua-calculate-indentation-block-modifier prev-line) 0))))) + + +(defun lua-make-indentation-info-pair () + "This is a helper function to lua-calculate-indentation-info. Don't +use standalone." + (cond ((string-equal found-token "function") + ;; this is the location where we need to start searching for the + ;; matching opening token, when we encounter the next closing token. + ;; It is primarily an optimization to save some searchingt ime. + (cons 'absolute (+ (save-excursion (goto-char found-pos) + (current-column)) + lua-indent-level))) + ((string-equal found-token "(") + ;; this is the location where we need to start searching for the + ;; matching opening token, when we encounter the next closing token. + ;; It is primarily an optimization to save some searchingt ime. + (cons 'absolute (+ (save-excursion (goto-char found-pos) + (current-column)) + 1))) + ((string-equal found-token "end") + (save-excursion + (lua-goto-matching-block-token nil found-pos) + (if (looking-at "\\<function\\>") + (cons 'absolute + (+ (current-indentation) + (lua-calculate-indentation-block-modifier + nil (point)))) + (cons 'relative (- lua-indent-level))))) + ((string-equal found-token ")") + (save-excursion + (lua-goto-matching-block-token nil found-pos) + (cons 'absolute + (+ (current-indentation) + (lua-calculate-indentation-block-modifier + nil (point)))))) + (t + (cons 'relative (if (nth 2 (match-data)) + ;; beginning of a block matched + lua-indent-level + ;; end of a block matched + (- lua-indent-level)))))) + + +(defun lua-calculate-indentation-info (&optional parse-start parse-end) + "For each block token on the line, computes how it affects the indentation. +The effect of each token can be either a shift relative to the current +indentation level, or indentation to some absolute column. This information +is collected in a list of indentation info pairs, which denote absolute +and relative each, and the shift/column to indent to." + (let* ((line-end (save-excursion (end-of-line) (point))) + (search-stop (if parse-end (min parse-end line-end) line-end)) + (indentation-info nil)) + (if parse-start (goto-char parse-start)) + (save-excursion + (beginning-of-line) + (while (lua-find-regexp 'forward lua-indentation-modifier-regexp + search-stop) + (let ((found-token (match-string 0)) + (found-pos (match-beginning 0)) + (found-end (match-end 0)) + (data (match-data))) + (setq indentation-info + (cons (lua-make-indentation-info-pair) indentation-info))))) + indentation-info)) + + +(defun lua-accumulate-indentation-info (info) + "Accumulates the indentation information previously calculated by +lua-calculate-indentation-info. Returns either the relative indentation +shift, or the absolute column to indent to." + (let ((info-list (reverse info)) + (type 'relative) + (accu 0)) + (mapcar (lambda (x) + (setq accu (if (eq 'absolute (car x)) + (progn (setq type 'absolute) + (cdr x)) + (+ accu (cdr x))))) + info-list) + (cons type accu))) + + + +(defconst lua-indentation-modifier-regexp + (eval-when-compile + ;; The absence of else is deliberate, since it does not modify the + ;; indentation level per se. It only may cause the line, in which the + ;; else is, to be shifted to the left. + ;; This is the code we used to generate the regexp: + (concat + "\\(\\<" + ; n.b. "local function" is a bit of a hack, allowing only a single space + (regexp-opt '("do" "local function" "function" "repeat" "then") t) + "\\>\\|" + (regexp-opt '("{" "(" "[")) + "\\)\\|\\(\\<" + (regexp-opt '("elseif" "end" "until") t) + "\\>\\|" + (regexp-opt '("]" ")" "}")) + "\\)") + + )) + + +(defun lua-calculate-indentation-block-modifier (&optional parse-start + parse-end) + "Return amount by which this line modifies the indentation. +Beginnings of blocks add lua-indent-level once each, and endings +of blocks subtract lua-indent-level once each. This function is used +to determine how the indentation of the following line relates to this +one." + (if parse-start (goto-char parse-start)) + (let ((case-fold-search nil) + (indentation-info (lua-accumulate-indentation-info + (lua-calculate-indentation-info nil parse-end)))) + (if (eq (car indentation-info) 'absolute) + (- (cdr indentation-info) (current-indentation)) + (+ (lua-calculate-indentation-left-shift) + (cdr indentation-info) + (if (lua-is-continuing-statement-p) (- lua-indent-level) 0))))) + + +(defconst lua-left-shift-regexp-1 + (eval-when-compile + (concat "\\(" + "\\(\\<" (regexp-opt '("else" "elseif" "until") t) + "\\>\\)\\($\\|\\s +\\)" + "\\)"))) + +(defconst lua-left-shift-regexp-2 + (eval-when-compile + (concat "\\(\\<" + (regexp-opt '("end") t) + "\\>\\)"))) + +(defconst lua-left-shift-regexp + (eval-when-compile + ;; This is the code we used to generate the regexp: + ;; ("else", "elseif", "until" followed by whitespace, or "end"/closing + ;; brackets followed by + ;; whitespace, punctuation, or closing parentheses) + (concat lua-left-shift-regexp-1 + "\\|\\(\\(" + lua-left-shift-regexp-2 + "\\|\\(" + (regexp-opt '("]" "}" ")")) + "\\)\\)\\($\\|\\(\\s \\|\\s.\\)*\\)" + "\\)"))) + +(defconst lua-left-shift-pos-1 + 2) + +(defconst lua-left-shift-pos-2 + (eval-when-compile + (+ 3 (regexp-opt-depth lua-left-shift-regexp-1)))) + +(defconst lua-left-shift-pos-3 + (eval-when-compile + (+ lua-left-shift-pos-2 + (regexp-opt-depth lua-left-shift-regexp-2)))) + + +(defun lua-calculate-indentation-left-shift (&optional parse-start) + "Return amount, by which this line should be shifted left. +Look for an uninterrupted sequence of block-closing tokens that starts +at the beginning of the line. For each of these tokens, shift indentation +to the left by the amount specified in lua-indent-level." + (let (line-begin + (indentation-modifier 0) + (case-fold-search nil) + (block-token nil)) + (save-excursion + (if parse-start (goto-char parse-start)) + (beginning-of-line) + (setq line-begin (point)) + ;; Look for the block-closing token sequence + (skip-chars-forward lua-indent-whitespace) + (catch 'stop + (while (and (looking-at lua-left-shift-regexp) + (not (lua-comment-or-string-p))) + (let ((last-token (or (match-string lua-left-shift-pos-1) + (match-string lua-left-shift-pos-2) + (match-string lua-left-shift-pos-3)))) + (if (not block-token) (setq block-token last-token)) + (if (not (string-equal block-token last-token)) (throw 'stop nil)) + (setq indentation-modifier (+ indentation-modifier + lua-indent-level)) + (forward-char (length (match-string 0)))))) + indentation-modifier))) + + +;;{{{ lua-calculate-indentation + +(defun lua-calculate-indentation (&optional parse-start) + "Return appropriate indentation for current line as Lua code. +In usual case returns an integer: the column to indent to." + (let ((pos (point)) + shift-amt) + (save-excursion + (if parse-start (setq pos (goto-char parse-start))) + (beginning-of-line) + (setq shift-amt (if (lua-is-continuing-statement-p) lua-indent-level 0)) + (if (bobp) ; If we're at the beginning of the buffer, no change. + (+ (current-indentation) shift-amt) + ;; This code here searches backwards for a "block beginning/end" + ;; It snarfs the indentation of that, plus whatever amount the + ;; line was shifted left by, because of block end tokens. It + ;; then adds the indentation modifier of that line to obtain the + ;; final level of indentation. + ;; Finally, if this line continues a statement from the + ;; previous line, add another level of indentation. + (if (lua-backwards-to-block-begin-or-end) + ;; now we're at the line with block beginning or end. + (max (+ (current-indentation) + (lua-calculate-indentation-block-modifier) + shift-amt) + 0) + ;; Failed to find a block begin/end. + ;; Just use the previous line's indent. + (goto-char pos) + (beginning-of-line) + (forward-line -1) + (+ (current-indentation) shift-amt)))))) + +;;}}} + +;;}}} +;;{{{ searching + +;;{{{ lua-beginning-of-proc + +(defun lua-beginning-of-proc (&optional arg) + "Move backward to the beginning of a lua proc (or similar). +With argument, do it that many times. Negative arg -N +means move forward to Nth following beginning of proc. +Returns t unless search stops due to beginning or end of buffer." + (interactive "P") + (or arg + (setq arg 1)) + (let ((found nil) + (ret t)) + (if (and (< arg 0) + (looking-at "^function[ \t]")) + (forward-char 1)) + (while (< arg 0) + (if (re-search-forward "^function[ \t]" nil t) + (setq arg (1+ arg) + found t) + (setq ret nil + arg 0))) + (if found + (beginning-of-line)) + (while (> arg 0) + (if (re-search-backward "^function[ \t]" nil t) + (setq arg (1- arg)) + (setq ret nil + arg 0))) + ret)) + +;;}}} +;;{{{ lua-end-of-proc + +(defun lua-end-of-proc (&optional arg) + "Move forward to next end of lua proc (or similar). +With argument, do it that many times. Negative argument -N means move +back to Nth preceding end of proc. + +This function just searches for a `end' at the beginning of a line." + (interactive "P") + (or arg + (setq arg 1)) + (let ((found nil) + (ret t)) + (if (and (< arg 0) + (not (bolp)) + (save-excursion + (beginning-of-line) + (eq (following-char) ?}))) + (forward-char -1)) + (while (> arg 0) + (if (re-search-forward "^end" nil t) + (setq arg (1- arg) + found t) + (setq ret nil + arg 0))) + (while (< arg 0) + (if (re-search-backward "^end" nil t) + (setq arg (1+ arg) + found t) + (setq ret nil + arg 0))) + (if found + (end-of-line)) + ret)) + +;;}}} + +;;}}} + +;;{{{ communication with a inferior process via comint + +;;{{{ lua-start-process + +(defun lua-start-process (name program &optional startfile &rest switches) + "Start a lua process named NAME, running PROGRAM." + (or switches + (setq switches lua-default-command-switches)) + (setq lua-process-buffer (apply 'make-comint name program startfile switches)) + (setq lua-process (get-buffer-process lua-process-buffer)) + (save-excursion + (set-buffer lua-process-buffer)) + ) + +;;}}} +;;{{{ lua-kill-process + +(defun lua-kill-process () + "Kill lua subprocess and its buffer." + (interactive) + (if lua-process-buffer + (kill-buffer lua-process-buffer))) + +;;}}} +;;{{{ lua-set-lua-region-start + +(defun lua-set-lua-region-start (&optional arg) + "Set start of region for use with `lua-send-lua-region'." + (interactive) + (set-marker lua-region-start (or arg (point)))) + +;;}}} +;;{{{ lua-set-lua-region-end + +(defun lua-set-lua-region-end (&optional arg) + "Set end of region for use with `lua-send-lua-region'." + (interactive) + (set-marker lua-region-end (or arg (point)))) + +;;}}} +;;{{{ send line/region/buffer to lua-process + +;;{{{ lua-send-current-line + +(defun lua-send-current-line () + "Send current line to lua subprocess, found in `lua-process'. +If `lua-process' is nil or dead, start a new process first." + (interactive) + (let ((start (save-excursion (beginning-of-line) (point))) + (end (save-excursion (end-of-line) (point)))) + (or (and lua-process + (eq (process-status lua-process) 'run)) + (lua-start-process lua-default-application lua-default-application)) + (comint-simple-send lua-process + (concat lua-default-command-switches + (buffer-substring start end) " +\n")) + (forward-line 1) + (if lua-always-show + (display-buffer lua-process-buffer)))) + +;;}}} +;;{{{ lua-send-region + +(defun lua-send-region (start end) + "Send region to lua subprocess." + (interactive "r") + (or (and lua-process + (comint-check-proc lua-process-buffer)) + (lua-start-process lua-default-application lua-default-application)) + (comint-simple-send lua-process + (buffer-substring start end)) + (if lua-always-show + (display-buffer lua-process-buffer))) + +;;}}} +;;{{{ lua-send-lua-region + +(defun lua-send-lua-region () + "Send preset lua region to lua subprocess." + (interactive) + (or (and lua-region-start lua-region-end) + (error "lua-region not set")) + (or (and lua-process + (comint-check-proc lua-process-buffer)) + (lua-start-process lua-default-application lua-default-application)) + (comint-simple-send lua-process + (buffer-substring lua-region-start lua-region-end) +) + (if lua-always-show + (display-buffer lua-process-buffer))) + +;;}}} +;;{{{ lua-send-proc + +(defun lua-send-proc () + "Send proc around point to lua subprocess." + (interactive) + (let (beg end) + (save-excursion + (lua-beginning-of-proc) + (setq beg (point)) + (lua-end-of-proc) + (setq end (point))) + (or (and lua-process + (comint-check-proc lua-process-buffer)) + (lua-start-process lua-default-application lua-default-application)) + (comint-simple-send lua-process + (buffer-substring beg end)) + (if lua-always-show + (display-buffer lua-process-buffer)))) + +;;}}} +;;{{{ lua-send-buffer + +; This needs work... -Bret +(defun lua-send-buffer () + "Send whole buffer to lua subprocess." + (interactive) + (or (and lua-process + (comint-check-proc lua-process-buffer)) + (lua-start-process lua-default-application lua-default-application)) + (if (buffer-modified-p) + (comint-simple-send lua-process + (buffer-substring (point-min) (point-max))) + (comint-simple-send lua-process + (concat "dofile(\"" + (buffer-file-name) "\")\n"))) + (if lua-always-show + (display-buffer lua-process-buffer))) + +;;}}} + +;;}}} + +;;{{{ lua-restart-with-whole-file + +(defun lua-restart-with-whole-file () + "Restart lua subprocess and send whole file as input." + (interactive) + (lua-kill-process) + (lua-start-process lua-default-application lua-default-application) + (lua-send-buffer)) + +;;}}} +;;{{{ lua-show-process-buffer + +(defun lua-show-process-buffer () + "Make sure `lua-process-buffer' is being displayed." + (interactive) + (display-buffer lua-process-buffer)) + +;;}}} +;;{{{ lua-hide-process-buffer + +(defun lua-hide-process-buffer () + "Delete all windows that display `lua-process-buffer'." + (interactive) + (delete-windows-on lua-process-buffer)) + +;;}}} + +;;}}} + +;;{{{ menu bar + +(define-key lua-mode-menu [restart-with-whole-file] + '("Restart With Whole File" . lua-restart-with-whole-file)) +(define-key lua-mode-menu [kill-process] + '("Kill Process" . lua-kill-process)) + +(define-key lua-mode-menu [hide-process-buffer] + '("Hide Process Buffer" . lua-hide-process-buffer)) +(define-key lua-mode-menu [show-process-buffer] + '("Show Process Buffer" . lua-show-process-buffer)) + +(define-key lua-mode-menu [end-of-proc] + '("End Of Proc" . lua-end-of-proc)) +(define-key lua-mode-menu [beginning-of-proc] + '("Beginning Of Proc" . lua-beginning-of-proc)) + +(define-key lua-mode-menu [send-lua-region] + '("Send Lua-Region" . lua-send-lua-region)) +(define-key lua-mode-menu [set-lua-region-end] + '("Set Lua-Region End" . lua-set-lua-region-end)) +(define-key lua-mode-menu [set-lua-region-start] + '("Set Lua-Region Start" . lua-set-lua-region-start)) + +(define-key lua-mode-menu [send-current-line] + '("Send Current Line" . lua-send-current-line)) +(define-key lua-mode-menu [send-region] + '("Send Region" . lua-send-region)) +(define-key lua-mode-menu [send-proc] + '("Send Proc" . lua-send-proc)) +(define-key lua-mode-menu [send-buffer] + '("Send Buffer" . lua-send-buffer)) + +(defvar lua-xemacs-menu + '(["Restart With Whole File" lua-restart-with-whole-file t] + ["Kill Process" lua-kill-process t] + ["Hide Process Buffer" lua-hide-process-buffer t] + ["Show Process Buffer" lua-show-process-buffer t] + ["Beginning Of Proc" lua-beginning-of-proc t] + ["End Of Proc" lua-end-of-proc t] + ["Set Lua-Region Start" lua-set-lua-region-start t] + ["Set Lua-Region End" lua-set-lua-region-end t] + ["Send Lua-Region" lua-send-lua-region t] + ["Send Current Line" lua-send-current-line t] + ["Send Region" lua-send-region t] + ["Send Proc" lua-send-proc t] + ["Send Buffer" lua-send-buffer t]) + "XEmacs menu for Lua mode.") + +;;}}} + +(provide 'lua-mode) + + +;;{{{ Emacs local variables + +;; Local Variables: +;; folded-file: t +;; End: + +;;}}} + +;;; lua-mode.el ends here diff --git a/emacs-lisp/modes/p4.el b/emacs-lisp/modes/p4.el new file mode 100644 index 0000000..48c5d1b --- /dev/null +++ b/emacs-lisp/modes/p4.el @@ -0,0 +1,3682 @@ +;;; p4.el --- Simple Perforce-Emacs Integration +;; +;; $Id: p4.el,v 1.62 2002/10/24 15:42:51 rvgnu Exp $ + +;;; Commentary: +;; +;; Applied the GNU G.P.L. to this file - rv 3/27/1997 + +;; Programs for Emacs <-> Perforce Integration. +;; Copyright (C) 1996, 1997 Eric Promislow +;; Copyright (C) 1997-2001 Rajesh Vaidheeswarran +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;; If you have any problems to report, or suggestions, please send them +;; to p4el-bugs@lists.sourceforge.net + +;; LCD Archive Entry: +;; p4|Rajesh Vaidheeswarran|rv@NoSpAm.lOsEtHiS.dsmit.com| +;; P4 SCM Integration into Emacs/XEmacs| +;; 2002/10/24|10.2|not_assigned_yet| + +;; WARNING: +;; -------- +;; +;; % p4 edit foo.c +;; ... make changes to foo.c in emacs +;; % p4 submit +;; ... keep the writable copy of foo.c in emacs. Start making changes +;; to it. Discover that you can't save it. If you do M-x:p4-edit, +;; you'll lose your changes. You need to do a 'p4 edit' at the +;; command-line. +;; + +;; NOTES: +;; ------ +;; +;; It is best if you take this file and byte compile it. To do that, you +;; need to do the following: +;; +;; % emacs -batch -f batch-byte-compile /full/path/to/file/p4.el +;; +;; This creates a binary file p4.elc in the path. Add the path to your +;; load-path variable in .emacs like this: +;; +;; (setq load-path (cons "/full/path/to/file" load-path)) +;; +;; Then add the library like this: +;; +;; (load-library "p4") +;; + +;;; Code: + +(defvar p4-emacs-version "10.2" "The Current P4-Emacs Integration Revision.") + +;; Find out what type of emacs we are running in. We will be using this +;; quite a few times in this program. +(eval-and-compile + (defvar p4-running-emacs nil + "If the current Emacs is not XEmacs, then, this is non-nil.") + (defvar p4-running-xemacs nil + "If the current Emacs is XEmacs/Lucid, then, this is non-nil.") + (if (string-match "XEmacs\\|Lucid" emacs-version) + (setq p4-running-xemacs t) + (setq p4-running-emacs t))) + +;; Pick up a couple of missing function defs +(if p4-running-xemacs + (eval-when-compile + (require 'timer) + (require 'dired))) + +(defvar p4-emacs-maintainer + "p4.el maintainers <p4el-bugs@lists.sourceforge.net>" + "The maintainer(s) of the emacs-p4 integration. Used for bug reports.") + +(defvar p4-web-page "http://p4el.sourceforge.net/" "The home of p4.el.") + +;; For flavors of Emacs which don't define `defgroup' and `defcustom'. +(eval-when-compile + (if (not (fboundp 'defgroup)) + (defmacro defgroup (sym memb doc &rest args) + "Null macro for defgroup in all versions of Emacs that don't define +defgroup" + t)) + (if (not (fboundp 'defcustom)) + (defmacro defcustom (sym val doc &rest args) + "Macro to alias defcustom to defvar in all versions of Emacs that +don't define defcustom" + `(defvar ,sym ,val ,doc)))) + +(defgroup p4 nil "Perforce VC System." :group 'tools) + +;; This can be set to wherever 'p4' lies using p4-set-p4-executable +(eval-and-compile + (defun p4-windows-os () + (memq system-type '(ms-dos windows-nt))) + + (defcustom p4-executable + (let ((lst (append + exec-path + (list "/usr/local/bin/p4" + (concat (getenv "HOME") "/bin/p4") + "p4"))) + (p4-progname (if (p4-windows-os) "p4.exe" "p4")) + p4ex) + (while (and lst (not p4ex)) + (let ((tmp (concat (file-name-as-directory (car lst)) + p4-progname))) + (if (and (file-executable-p tmp) + (not (file-directory-p tmp))) + (setq p4ex tmp)) + (setq lst (cdr lst)))) + p4ex) + "This is the p4 executable. +To set this, use the function `p4-set-p4-executable' or `customize'" + :type 'string + :group 'p4)) + +;; This is a string with default arguments to pass to "p4 diff", +;; "p4 diff2", "p4 describe", etc. +(defcustom p4-default-diff-options "-du" + "Type of p4 diff output to be displayed. \(regular or context or +unified.\)" + :type 'string + :group 'p4) + +(defcustom p4-default-depot-completion-prefix "//depot/" + "Prefix to be used for completion prompt when prompting user for a depot +file." + :type 'string + :group 'p4) + +;; Set this variable to nil to turn off colorized diff buffers. +(defcustom p4-colorized-diffs t + "Set this to nil to disable colorized diffs." + :type 'boolean + :group 'p4) + +;; Set whether P4CONFIG should be used exclusively for VC checking +(defcustom p4-use-p4config-exclusively nil + "Whether P4 mode should use P4CONFIG exclusively to check whether a file +is under P4 version control. If set to nil, `p4-check-mode' is always +called; otherwise, it checks to see if the file named by P4CONFIG exists in +this or a parent directory, and if so, only then runs p4-check-mode. + +This provides for a much faster `p4-find-file-hook'." + :type 'boolean + :group 'p4) + +;; Auto-refresh? +(defcustom p4-auto-refresh t + "Set this to automatically refresh p4 submitted files in buffers." + :type 'boolean + :group 'p4) + +;; Check for empty diffs at submit time +(defcustom p4-check-empty-diffs t + "Set this to check for files with empty diffs before submitting." + :type 'boolean + :group 'p4) + +(defcustom p4-verbose t + "When set, p4 will pop up the output buffer with the result of the +command." + :type 'boolean + :group 'p4) + +;; Follow Symlinks? +(defcustom p4-follow-symlinks nil + "When set, p4 will call `file-truename' on all opened files." + :type 'boolean + :group 'p4) + +(defcustom p4-mode-hook nil + "Hook run by `p4-mode'." + :type 'sexp + :group 'p4) + +(eval-and-compile + (defvar p4-output-buffer-name "*P4 Output*" "P4 Output Buffer.")) + +;; Set this variable in .emacs if you want p4-set-client-name to complete +;; your client name for you. +(defvar p4-my-clients nil + "This variable holds the alist of p4 clients that the function +`p4-set-client-name' can complete on. + +Set this variable *only* if you don't want P4 to complete on all the clients +in the P4 server. + +This is a alist, and should be set using the function +`p4-set-my-clients'. For example, in your .emacs: + +\(load-library \"p4\"\) +\(p4-set-my-clients \'(client1 client2 client3)\)") + +;; Set this variable in .emacs if you want to alter the completion +;; behavior of p4-set-client-name. + +(defcustom p4-strict-complete t + "Set this variable in .emacs \(or using `customize'\) if you want to alter +the completion behavior of `p4-set-client-name'. +" + :type 'boolean + :group 'p4) + +(if (not (getenv "P4PORT")) + (setenv "P4PORT" "perforce:1666")) + +(defvar p4-notify-list (getenv "P4NOTIFY") "The P4 Notify List.") + +(defcustom p4-sendmail-program (if (boundp 'sendmail-program) + sendmail-program + nil) + "The sendmail program. To set this use `customize'." + :type 'string + :group 'p4) + +(defcustom p4-user-email (if (boundp 'user-mail-address) + user-mail-address nil) + "The e-mail address of the current user. This is used with the +notification system, and must be set if notification should take place. To +set this, use `customize'." + :type 'string + :group 'p4) + +(defcustom p4-notify nil + "If this is t then the users in the notification list set by +`p4-set-notify-list' will get a notification of any P4 change submitted from +within emacs." + :type 'boolean + :group 'p4) + +;; This can be set with p4-toggle-vc-mode +(defcustom p4-do-find-file t + "If non-nil, the `p4-find-file-hook' will run when opening files." + :type 'boolean + :group 'p4) + +;; Now add a hook to find-file-hooks +(add-hook 'find-file-hooks 'p4-find-file-hook) +;; .. and one to kill-buffer-hook +(add-hook 'kill-buffer-hook 'p4-kill-buffer-hook) + +;; Tell Emacs about this new kind of minor mode +(defvar p4-mode nil "Is this file under p4?") +(make-variable-buffer-local 'p4-mode) +(put 'p4-mode 'permanent-local t) + +(defvar p4-offline-mode nil "Is this file under p4 but handled in offline mode?") +(make-variable-buffer-local 'p4-offline-mode) +(put 'p4-offline-mode 'permanent-local t) + +(defvar p4-minor-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-x\C-q" 'p4-toggle-read-only) + map) + "Keymap for p4 minor mode") +(fset 'p4-minor-map p4-minor-map) +(or (assoc 'p4-mode minor-mode-alist) + (setq minor-mode-alist (cons '(p4-mode p4-mode) + minor-mode-alist))) +(or (assoc 'p4-mode minor-mode-map-alist) + (setq minor-mode-map-alist + (cons '(p4-mode . p4-minor-map) minor-mode-map-alist))) +(or (assoc 'p4-offline-mode minor-mode-alist) + (setq minor-mode-alist (cons '(p4-offline-mode p4-offline-mode) + minor-mode-alist))) +(or (assoc 'p4-offline-mode minor-mode-map-alist) + (setq minor-mode-map-alist + (cons '(p4-offline-mode . p4-minor-map) minor-mode-map-alist))) + +(defvar p4-async-minor-mode nil + "The minor mode for editing p4 asynchronous command buffers.") +(make-variable-buffer-local 'p4-async-minor-mode) +(defvar p4-async-minor-map (make-sparse-keymap) "Keymap for p4 async minor mode") +(fset 'p4-async-minor-map p4-async-minor-map) + +(or (assoc 'p4-async-minor-mode minor-mode-alist) + (setq minor-mode-alist + (cons '(p4-async-minor-mode " P4") minor-mode-alist))) + +(or (assoc 'p4-async-minor-mode minor-mode-map-alist) + (setq minor-mode-map-alist + (cons '(p4-async-minor-mode . p4-async-minor-map) minor-mode-map-alist))) + +(defvar p4-current-command nil) +(make-variable-buffer-local 'p4-current-command) +(put 'p4-current-command 'permanent-local t) +(set-default 'p4-current-command nil) + +(defvar p4-current-args nil) +(make-variable-buffer-local 'p4-current-args) +(put 'p4-current-args 'permanent-local t) +(set-default 'p4-current-args nil) + +;; To check if the current buffer's modeline and menu need to be altered +(defvar p4-vc-check nil) +(make-variable-buffer-local 'p4-vc-check) +(put 'p4-vc-check 'permanent-local t) +(set-default 'p4-vc-check nil) + +(defvar p4-set-client-hooks nil + "List of functions to be called after a p4 client is changed. +The buffer's local variables (if any) will have been processed before the +functions are called.") + +(if p4-running-emacs (require 'timer)) + +(defvar p4-timer nil "Timer object that will be set to cleanup the caches +periodically.") + +(defcustom p4-cleanup-time 600 "seconds after which `p4-cache-cleanup' will +check for dirty caches." + :type 'integer + :group 'p4) + +(defcustom p4-cleanup-cache t "`p4-cache-cleanup' will cleanup the +branches/clients/dirs/labels caches once in a while if this is non-nil." + :type 'boolean + :group 'p4) + +(defvar p4-all-buffer-files nil "An associated list of all buffers and +their files under p4 version control. This is to enable autorefreshing of +p4 submitted files being visited by the buffer.") + +(defvar p4-file-refresh-timer nil "Timer object that will be set to refresh +the files in Emacs buffers that have been modified by a `p4-submit'.") + +(defcustom p4-file-refresh-timer-time 60 "seconds after which +`p4-file-refresh' will check for modified files in Emacs buffers. Set this +variable to 0 to disable periodic refreshing." + :type 'integer + :group 'p4) + +(defvar p4-async-command-hook nil + "This hook is run after an async buffer has been set up by +`p4-async-process-command'") + +(defvar p4-window-config-stack nil + "Stack of saved window configurations.") + +(defcustom p4-window-config-stack-size 20 "Maximum stack size +for saved window configurations." + :type 'integer + :group 'p4) + +(defcustom p4-exec-arg-len-max 20000 "Maximum total length of all +arguments to p4 commands." + :type 'integer + :group 'p4) + +(defvar p4-basic-map + (let ((map (make-sparse-keymap))) + (cond (p4-running-xemacs + (define-key map [button2] 'p4-buffer-mouse-clicked) + (define-key map [button3] 'p4-buffer-mouse-clicked-3)) + (p4-running-emacs + (define-key map [mouse-2] 'p4-buffer-mouse-clicked) + (define-key map [mouse-3] 'p4-buffer-mouse-clicked-3))) + (define-key map [return] 'p4-buffer-commands) + (define-key map "\r" 'p4-buffer-commands) + (define-key map "q" 'p4-quit-current-buffer) + (define-key map "k" 'p4-scroll-down-1-line) + (define-key map "j" 'p4-scroll-up-1-line) + (define-key map "b" 'p4-scroll-down-1-window) + (define-key map [backspace] 'p4-scroll-down-1-window) + (define-key map " " 'p4-scroll-up-1-window) + (define-key map "<" 'p4-top-of-buffer) + (define-key map ">" 'p4-bottom-of-buffer) + (define-key map "=" 'p4-delete-other-windows) + map)) + +(defun p4-make-derived-map (base-map) + (let (map) + (cond (p4-running-xemacs + (setq map (make-sparse-keymap)) + (set-keymap-parents map (list base-map))) + (p4-running-emacs + (setq map (cons 'keymap base-map)))) + map)) + +(defvar p4-filelog-map + (let ((map (p4-make-derived-map p4-basic-map))) + (define-key map "d" 'p4-diff2) + (define-key map "f" 'p4-find-file-other-window) + (define-key map "s" 'p4-filelog-short-format) + (define-key map "l" 'p4-filelog-long-format) + (define-key map "k" 'p4-scroll-down-1-line-other-w) + (define-key map "j" 'p4-scroll-up-1-line-other-w) + (define-key map "b" 'p4-scroll-down-1-window-other-w) + (define-key map [backspace] 'p4-scroll-down-1-window-other-w) + (define-key map " " 'p4-scroll-up-1-window-other-w) + (define-key map "<" 'p4-top-of-buffer-other-w) + (define-key map ">" 'p4-bottom-of-buffer-other-w) + (define-key map "=" 'p4-delete-other-windows) + (define-key map "n" 'p4-goto-next-change) + (define-key map "p" 'p4-goto-prev-change) + (define-key map "N" (lookup-key map "p")) + map) + "The key map to use for selecting filelog properties.") + +(defvar p4-opened-map + (let ((map (p4-make-derived-map p4-basic-map))) + (define-key map "n" 'p4-next-depot-file) + (define-key map "p" 'p4-prev-depot-file) + (define-key map "N" (lookup-key map "p")) + map) + "The key map to use for selecting opened files.") + +(defvar p4-diff-map + (let ((map (p4-make-derived-map p4-basic-map))) + (define-key map "n" 'p4-goto-next-diff) + (define-key map "p" 'p4-goto-prev-diff) + (define-key map "N" (lookup-key map "p")) + (define-key map "d" 'p4-next-depot-diff) + (define-key map "u" 'p4-prev-depot-diff) + map)) + +(defvar p4-print-rev-map + (let ((map (p4-make-derived-map p4-basic-map))) + (define-key map "n" 'p4-next-change-rev-line) + (define-key map "p" 'p4-prev-change-rev-line) + (define-key map "N" (lookup-key map "p")) + (define-key map "l" 'p4-toggle-line-wrap) + map) + "The key map to use for browsing print-revs buffers.") + +;;; All functions start here. + +;; A generic function that we use to execute p4 commands +(eval-and-compile + (defun p4-exec-p4 (output-buffer args &optional clear-output-buffer) + "Internal function called by various p4 commands." + (save-excursion + (if (eq major-mode 'dired-mode) + (let ((dir (dired-current-directory))) + (set-buffer output-buffer) + (setq default-directory dir))) + (if clear-output-buffer + (progn + (set-buffer output-buffer) + (delete-region (point-min) (point-max)))) + (let ((result + ;; XXX - call-process has changed from using + ;; p4-null-device to nil as its second argument + ;; in emacs version 21.1.1?? - rv 1/25/2002 + (apply 'call-process (p4-check-p4-executable) nil + output-buffer + nil ; update display? + args))) + (p4-menu-add) + (if (and p4-running-emacs + (boundp 'hilit-auto-rehighlight)) + (setq hilit-auto-rehighlight nil)) + result)))) + +(defun p4-push-window-config () + "Push the current window configuration on the `p4-window-config-stack' +stack." + (interactive) + (setq p4-window-config-stack + (cons (current-window-configuration) + p4-window-config-stack)) + (while (> (length p4-window-config-stack) p4-window-config-stack-size) + (setq p4-window-config-stack + (reverse (cdr (reverse p4-window-config-stack)))))) + +(defun p4-pop-window-config (num) + "Pop `num' elements from the `p4-window-config-stack' stack and use +the last popped element to restore the window configuration." + (interactive "p") + (while (> num 0) + (if (eq p4-window-config-stack nil) + (error "window config stack empty")) + (set-window-configuration (car p4-window-config-stack)) + (setq p4-window-config-stack (cdr p4-window-config-stack)) + (setq num (1- num))) + (message "window config popped (stack size %d)" + (length p4-window-config-stack))) + + +;; The menu definition is in the XEmacs format. Emacs parses and converts +;; this definition to its own menu creation commands. + +(defalias 'p4-toggle-vc-mode-off 'p4-toggle-vc-mode) +(defalias 'p4-toggle-vc-mode-on 'p4-toggle-vc-mode) + +(eval-and-compile + (defvar p4-menu-def + '(["Specify Arguments..." universal-argument t] + ["--" nil nil] + ["Add Current to P4" p4-add + (and (p4-buffer-file-name) (not p4-mode))] + ["Check out/Edit" p4-edit + (and (p4-buffer-file-name-2) (or (not p4-mode) buffer-read-only))] + ["Re-open" p4-reopen + (and (p4-buffer-file-name-2) (or (not p4-mode) (not buffer-read-only)))] + ["Revert File" p4-revert + (and (p4-buffer-file-name-2) (or (not p4-mode) (not buffer-read-only)))] + ["Delete File from Depot" p4-delete + (and (p4-buffer-file-name-2) (or (not p4-mode) buffer-read-only))] + ["Rename Depot File" p4-rename + (and (p4-buffer-file-name-2) (or (not p4-mode) buffer-read-only))] + ["Submit Changes" p4-submit t] + ["--" nil nil] + ["Sync/Get Files from Depot" p4-get t] + ["--" nil nil] + ["Show Opened Files" p4-opened t] + ["Filelog" p4-filelog (p4-buffer-file-name-2)] + ["Changes" p4-changes t] + ["Describe Change" p4-describe t] + ["--" nil nil] + ["Diff 2 Versions" p4-diff2 (p4-buffer-file-name-2)] + ["Diff Current" p4-diff t] + ["Diff All Opened Files" p4-diff-all-opened t] + ["Diff Current with Ediff" p4-ediff + (and (p4-buffer-file-name) (not buffer-read-only) p4-mode)] + ["--" nil nil] + ["Schedule Integrations" p4-integ t] + ["Resolve Conflicts" p4-resolve t] + ["--" nil nil] + ["Print" p4-print (p4-buffer-file-name-2)] + ["Print with Revision History" p4-blame + (p4-buffer-file-name-2)] + ["Find File using Depot Spec" p4-depot-find-file + p4-do-find-file] + ["--" nil nil] + ["Edit a Branch Specification" p4-branch t] + ["Edit a Label Specification" p4-label t] + ["Edit a Client Specification" p4-client t] + ["Edit a User Specification" p4-user t] + ["--" nil nil] + ["Show Version" p4-emacs-version t] + ["Disable P4 VC Check" p4-toggle-vc-mode-off + p4-do-find-file] + ["Enable P4 VC Check" p4-toggle-vc-mode-on + (not p4-do-find-file)] + ["--" nil nil] + ["Set P4 Config" p4-set-client-config p4-do-find-file] + ["Get Current P4 Config" p4-get-client-config + p4-do-find-file] + ["--" nil nil] + ["Set P4 Client" p4-set-client-name p4-do-find-file] + ["Get Current P4 Client" p4-get-client-name + p4-do-find-file] + ["--" nil nil] + ["Set P4 Server/Port" p4-set-p4-port p4-do-find-file] + ["Get Current P4 Server/Port" p4-get-p4-port + p4-do-find-file] + ["--" nil nil] + ["Set P4 Notification List" p4-set-notify-list + p4-mode] + ["Get P4 Notification List" p4-get-notify-list p4-notify] + ["--" nil nil] + ["Describe Key Bindings" p4-describe-bindings t] + ["Check for later versions of p4.el" p4-browse-web-page t] + ["--" nil nil] + ["Report Bug in p4.el" p4-bug-report t]) + "The P4 menu definition") + + (cond (p4-running-xemacs + ;; Menu Support for XEmacs + (require 'easymenu) + (defun p4-mode-menu (modestr) + (cons modestr p4-menu-def))) + + (p4-running-emacs + ;; Menu support for Emacs + (or (lookup-key global-map [menu-bar]) + (define-key global-map [menu-bar] (make-sparse-keymap "menu-bar"))) + (defvar menu-bar-p4-menu (make-sparse-keymap "P4")) + (setq menu-bar-final-items (cons 'p4-menu menu-bar-final-items)) + (define-key global-map [menu-bar p4-menu] + (cons "P4" menu-bar-p4-menu)) + (let ((m (reverse p4-menu-def)) + (separator-number 0)) + (while m + (let ((menu-text (elt (car m) 0)) + (menu-action (elt (car m) 1)) + (menu-pred (elt (car m) 2))) + (if menu-action + (progn + (define-key menu-bar-p4-menu (vector menu-action) + (cons menu-text menu-action)) + (put menu-action 'menu-enable menu-pred)) + (define-key menu-bar-p4-menu + (vector (make-symbol + (concat "separator-" + (int-to-string separator-number)))) + '("--")) + (setq separator-number (1+ separator-number)))) + (setq m (cdr m)))))) + + (defun p4-depot-output (command &optional args) + "Executes p4 command inside a buffer. +Returns the buffer." + (let ((buffer (generate-new-buffer p4-output-buffer-name))) + (p4-exec-p4 buffer (cons command args) t) + buffer)) + + (defun p4-check-p4-executable () + "Check if the `p4-executable' is nil, and if so, prompt the user for a +valid `p4-executable'." + (interactive) + (if (not p4-executable) + (call-interactively 'p4-set-p4-executable) + p4-executable)) + + (defun p4-menu-add () + "To add the P4 menu bar button for files that are already not in +the P4 depot or in the current client view.." + (interactive) + (cond (p4-running-xemacs + (if (not (boundp 'p4-mode)) + (setq p4-mode nil)) + (easy-menu-add (p4-mode-menu "P4")))) + t) + + (defun p4-help-text (cmd text) + (if cmd + (let ((buf (generate-new-buffer p4-output-buffer-name)) + (help-text "")) + (if (= (p4-exec-p4 buf (list "help" cmd) t) 0) + (setq help-text (save-excursion + (set-buffer buf) + (buffer-string)))) + (kill-buffer buf) + (concat text help-text)) + text)) + + ;; To set the path to the p4 executable + (defun p4-set-p4-executable (p4-exe-name) + "Set the path to the correct P4 Executable. + +To set this as a part of the .emacs, add the following to your .emacs: + +\(load-library \"p4\"\) +\(p4-set-p4-executable \"/my/path/to/p4\"\) + +Argument P4-EXE-NAME The new value of the p4 executable, with full path." + (interactive "fFull path to your P4 executable: " ) + (setq p4-executable p4-exe-name) + p4-executable)) + +;; The kill-buffer hook for p4. +(defun p4-kill-buffer-hook () + "To Remove a file and its associated buffer from our global list of P4 +controlled files." + (if p4-vc-check + (p4-refresh-refresh-list (p4-buffer-file-name) + (buffer-name)))) + +(defmacro defp4cmd (fkn &rest all-args) + (let ((args (car all-args)) + (help-cmd (cadr all-args)) + (help-txt (eval (cadr (cdr all-args)))) + (body (cdr (cddr all-args)))) + `(defalias ',fkn + ,(append (list 'lambda args + (p4-help-text help-cmd help-txt)) + body)))) + +(defun p4-noinput-buffer-action (cmd + do-revert + show-output + &optional arguments preserve-buffer) + "Internal function called by various p4 commands." + (save-excursion + (save-excursion + (if (not preserve-buffer) + (progn + (get-buffer-create p4-output-buffer-name);; We do these two lines + (kill-buffer p4-output-buffer-name))) ;; to ensure no duplicates + (p4-exec-p4 (get-buffer-create p4-output-buffer-name) + (append (list cmd) arguments) + t)) + (p4-partial-cache-cleanup cmd) + (if show-output + (if (and + (eq show-output 's) + (= (save-excursion + (set-buffer p4-output-buffer-name) + (count-lines (point-min) (point-max))) + 1) + (not (save-excursion + (set-buffer p4-output-buffer-name) + (goto-char (point-min)) + (looking-at "==== ")))) + (save-excursion + (set-buffer p4-output-buffer-name) + (message (buffer-substring (point-min) + (save-excursion + (goto-char (point-min)) + (end-of-line) + (point))))) + (p4-push-window-config) + (if (not (one-window-p)) + (delete-other-windows)) + (display-buffer p4-output-buffer-name t)))) + (if (and do-revert (p4-buffer-file-name)) + (revert-buffer t t))) + +;; The p4 edit command +(defp4cmd p4-edit (show-output) + "edit" "To open the current depot file for edit, type \\[p4-edit].\n" + (interactive (list p4-verbose)) + (let ((args (p4-buffer-file-name)) + refresh-after) + (if (or current-prefix-arg (not args)) + (progn + (setq args (if (p4-buffer-file-name-2) + (p4-buffer-file-name-2) + "")) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 edit: " (cons args 0)))) + (setq refresh-after t)) + (setq args (list args))) + (p4-noinput-buffer-action "edit" t (and show-output 's) args) + (if refresh-after + (p4-refresh-files-in-buffers))) + (p4-check-mode) + (p4-update-opened-list)) + +;; The p4 reopen command +(defp4cmd p4-reopen (show-output) + "reopen" + "To change the type or changelist number of an opened file, type \\[p4-reopen]. + +Argument SHOW-OUTPUT displays the *P4 Output* buffer on executing the +command if t.\n" + + (interactive (list p4-verbose)) + (let ((args (if (p4-buffer-file-name-2) + (p4-buffer-file-name-2) + ""))) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 reopen: " (cons args 0)))) + (p4-noinput-buffer-action "reopen" t (and show-output 's) args)) + (p4-check-mode) + (p4-update-opened-list)) + +;; The p4 revert command +(defp4cmd p4-revert (show-output) + "revert" "To revert all change in the current file, type \\[p4-revert].\n" + (interactive (list p4-verbose)) + (let ((args (p4-buffer-file-name)) + refresh-after) + (if (or current-prefix-arg (not args)) + (progn + (setq args (if (p4-buffer-file-name-2) + (p4-buffer-file-name-2) + "")) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 revert: " args))) + (setq refresh-after t)) + (setq args (list args))) + (if (yes-or-no-p "Really revert changes? ") + (progn + (p4-noinput-buffer-action "revert" t (and show-output 's) args) + (if refresh-after + (progn + (p4-refresh-files-in-buffers) + (p4-check-mode-all-buffers)) + (p4-check-mode)) + (p4-update-opened-list))))) + +;; The p4 lock command +(defp4cmd p4-lock () + "lock" "To lock an opened file against changelist submission, type \\[p4-lock].\n" + (interactive) + (let ((args (list (p4-buffer-file-name-2)))) + (if (or current-prefix-arg (not (p4-buffer-file-name-2))) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 lock: " + (p4-buffer-file-name-2))))) + (p4-noinput-buffer-action "lock" t 's args) + (p4-update-opened-list))) + +;; The p4 unlock command +(defp4cmd p4-unlock () + "unlock" "To release a locked file but leave open, type \\[p4-unlock].\n" + (interactive) + (let ((args (list (p4-buffer-file-name-2)))) + (if (or current-prefix-arg (not (p4-buffer-file-name-2))) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 unlock: " + (p4-buffer-file-name-2))))) + (p4-noinput-buffer-action "unlock" t 's args) + (p4-update-opened-list))) + +;; The p4 diff command +(defp4cmd p4-diff () + "diff" "To diff the current file and topmost depot version, type \\[p4-diff].\n" + (interactive) + (let ((args (p4-make-list-from-string p4-default-diff-options))) + (if (p4-buffer-file-name-2) + (setq args (append args + (list (p4-buffer-file-name-2))))) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 diff: " p4-default-diff-options)))) + (p4-noinput-buffer-action "diff" nil 's args) + (p4-activate-diff-buffer "*P4 diff*"))) + +(defun p4-diff-all-opened () + (interactive) + (p4-noinput-buffer-action "diff" nil 's + (p4-make-list-from-string p4-default-diff-options)) + (p4-activate-diff-buffer "*P4 diff*")) + + +(defun p4-get-file-rev (default-name rev) + (if (string-match "^\\([0-9]+\\|none\\|head\\|have\\)$" rev) + (setq rev (concat "#" rev))) + (cond ((string-match "^[#@]" rev) + (concat default-name rev)) + ((string= "" rev) + default-name) + (t + rev))) + +;; The p4 diff2 command +(defp4cmd p4-diff2 (version1 version2) + "diff2" "Display diff of two depot files. + +When visiting a depot file, type \\[p4-diff2] and enter the versions.\n" + (interactive + (let ((rev (get-char-property (point) 'rev))) + (if (and (not rev) (p4-buffer-file-name-2)) + (let ((rev-num 0)) + (setq rev (p4-is-vc nil (p4-buffer-file-name-2))) + (if rev + (setq rev-num (string-to-number rev))) + (if (> rev-num 1) + (setq rev (number-to-string (1- rev-num))) + (setq rev nil)))) + (list (p4-read-arg-string "First Depot File or Version# to diff: " rev) + (p4-read-arg-string "Second Depot File or Version# to diff: ")))) + (let (diff-version1 + diff-version2 + (diff-options (p4-make-list-from-string p4-default-diff-options))) + (if current-prefix-arg + (setq diff-options (p4-make-list-from-string + (p4-read-arg-string "Optional Args: " + p4-default-diff-options)))) + ;; try to find out if this is a revision number, or a depot file + (setq diff-version1 (p4-get-file-rev (p4-buffer-file-name-2) version1)) + (setq diff-version2 (p4-get-file-rev (p4-buffer-file-name-2) version2)) + + (p4-noinput-buffer-action "diff2" nil t + (append diff-options + (list diff-version1 + diff-version2))) + (p4-activate-diff-buffer "*P4 diff2*"))) + +(defp4cmd p4-diff-head () + "diff-head" "Display diff of file against the head revision in depot. + +When visiting a depot file, type \\[p4-diff-head].\n" + + (interactive) + (let (head-revision + (diff-options (p4-make-list-from-string p4-default-diff-options))) + (if current-prefix-arg + (setq diff-options (p4-make-list-from-string + (p4-read-arg-string "Optional Args: " + p4-default-diff-options)))) + (setq head-revision (p4-get-file-rev (p4-buffer-file-name-2) "head")) + + (p4-noinput-buffer-action "diff" nil t + (append diff-options + (list head-revision))) + (p4-activate-diff-buffer "*P4 diff vs. head*"))) + + +;; p4-ediff for all those who diff using ediff + +(defun p4-ediff () + "Use ediff to compare file with its original client version." + (interactive) + (require 'ediff) + (p4-noinput-buffer-action "print" nil nil + (list "-q" + (concat (p4-buffer-file-name) "#have"))) + (let ((local (current-buffer)) + (depot (get-buffer-create p4-output-buffer-name))) + (ediff-buffers local + depot + `((lambda () + (make-local-variable 'ediff-cleanup-hook) + (setq ediff-cleanup-hook + (cons (lambda () + (kill-buffer ,depot) + (p4-menu-add)) + ediff-cleanup-hook))))))) + +;; The p4 add command +(defp4cmd p4-add () + "add" "To add the current file to the depot, type \\[p4-add].\n" + (interactive) + (let ((args (p4-buffer-file-name)) + refresh-after) + (if (or current-prefix-arg (not args)) + (progn + (setq args (if (p4-buffer-file-name-2) + (p4-buffer-file-name-2) + "")) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 add: " (cons args 0)))) + (setq refresh-after t)) + (setq args (list args))) + (p4-noinput-buffer-action "add" nil 's args) + (if refresh-after + (p4-check-mode-all-buffers) + (p4-check-mode))) + (p4-update-opened-list)) + + +;; The p4 delete command +(defp4cmd p4-delete () + "delete" "To delete the current file from the depot, type \\[p4-delete].\n" + (interactive) + (let ((args (p4-buffer-file-name))) + (if (or current-prefix-arg (not args)) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 delete: " + (p4-buffer-file-name-2)))) + (setq args (list args))) + (if (yes-or-no-p "Really delete from depot? ") + (p4-noinput-buffer-action "delete" nil 's args))) + (p4-check-mode) + (p4-update-opened-list)) + +;; The p4 filelog command +(defp4cmd p4-filelog () + "filelog" + "To view a history of the change made to the current file, type \\[p4-filelog].\n" + (interactive) + (let ((file-name (p4-buffer-file-name-2))) + (if (or current-prefix-arg (not file-name)) + (setq file-name (p4-make-list-from-string + (p4-read-arg-string "p4 filelog: " file-name))) + (setq file-name (list file-name))) + (p4-file-change-log "filelog" file-name))) + +(defun p4-set-extent-properties (start end prop-list) + (cond (p4-running-xemacs + (let ((ext (make-extent start end))) + (while prop-list + (set-extent-property ext (caar prop-list) (cdar prop-list)) + (setq prop-list (cdr prop-list))))) + (p4-running-emacs + (let ((ext (make-overlay start end))) + (while prop-list + (overlay-put ext (caar prop-list) (cdar prop-list)) + (setq prop-list (cdr prop-list))))))) + +(defun p4-create-active-link (start end prop-list) + (p4-set-extent-properties start end + (append (list (cons 'face 'bold) + (cons 'mouse-face 'highlight)) + prop-list))) + +(defun p4-move-buffer-point-to-top (buf-name) + (if (get-buffer-window buf-name) + (save-selected-window + (select-window (get-buffer-window buf-name)) + (goto-char (point-min))))) + +(defun p4-file-change-log (cmd file-list-spec) + (let ((p4-filelog-buffer + (concat "*P4 " cmd ": " + (p4-list-to-string file-list-spec) "*"))) + (p4-noinput-buffer-action cmd nil t (cons "-l" file-list-spec)) + (p4-activate-file-change-log-buffer p4-filelog-buffer))) + +(defun p4-activate-file-change-log-buffer (bufname) + (let (p4-cur-rev p4-cur-change p4-cur-action + p4-cur-user p4-cur-client) + (p4-activate-print-buffer bufname nil) + (set-buffer bufname) + (setq buffer-read-only nil) + (goto-char (point-min)) + (while (re-search-forward (concat + "^\\(\\.\\.\\. #\\([0-9]+\\) \\)?[Cc]hange " + "\\([0-9]+\\) \\([a-z]+\\)?.*on.*by " + "\\([^ @]+\\)@\\([^ \n]+\\).*\n" + "\\(\\(\\([ \t].*\\)?\n\\)*\\)") nil t) + (let ((rev-match 2) + (ch-match 3) + (act-match 4) + (user-match 5) + (cl-match 6) + (desc-match 7)) + (setq p4-cur-rev (match-string rev-match)) + (setq p4-cur-change (match-string ch-match)) + (setq p4-cur-action (match-string act-match)) + (setq p4-cur-user (match-string user-match)) + (setq p4-cur-client (match-string cl-match)) + + (if (match-beginning rev-match) + (p4-create-active-link (match-beginning rev-match) + (match-end rev-match) + (list (cons 'rev p4-cur-rev)))) + (p4-create-active-link (match-beginning ch-match) + (match-end ch-match) + (list (cons 'change p4-cur-change))) + (if (match-beginning act-match) + (p4-create-active-link (match-beginning act-match) + (match-end act-match) + (list (cons 'action p4-cur-action) + (cons 'rev p4-cur-rev)))) + (p4-create-active-link (match-beginning user-match) + (match-end user-match) + (list (cons 'user p4-cur-user))) + (p4-create-active-link (match-beginning cl-match) + (match-end cl-match) + (list (cons 'client p4-cur-client))) + (p4-set-extent-properties (match-beginning desc-match) + (match-end desc-match) + (list (cons 'invisible t) + (cons 'isearch-open-invisible t))))) + (p4-find-change-numbers bufname (point-min) (point-max)) + (use-local-map p4-filelog-map) + (setq buffer-invisibility-spec (list)) + (setq buffer-read-only t) + (p4-move-buffer-point-to-top bufname))) + +;; Scan specified region for references to change numbers +;; and make the change numbers clickable. +(defun p4-find-change-numbers (buffer start end) + (save-excursion + (set-buffer buffer) + (goto-char start) + (while (re-search-forward "\\(changes?\\|submit\\|p4\\)[:#]?[ \t\n]+" end t) + (while (looking-at + (concat "\\([#@]\\|number\\|no\\.\\|\\)[ \t\n]*" + "\\([0-9]+\\)[-, \t\n]*" + "\\(and/or\\|and\\|&\\|or\\|\\)[ \t\n]*")) + (let ((ch-start (match-beginning 2)) + (ch-end (match-end 2)) + (ch-str (match-string 2)) + (next (match-end 0))) + (set-text-properties 0 (length ch-str) nil ch-str) + (p4-create-active-link ch-start ch-end (list (cons 'change ch-str))) + (goto-char next)))))) + +;; The p4 files command +(defp4cmd p4-files () + "files" "List files in the depot. Type, \\[p4-files].\n" + (interactive) + (let ((args (p4-buffer-file-name-2))) + (if (or current-prefix-arg (not args)) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 files: " (p4-buffer-file-name-2)))) + (setq args (list args))) + (p4-noinput-buffer-action "files" nil t args) + (save-excursion + (set-buffer p4-output-buffer-name) + (p4-find-change-numbers p4-output-buffer-name (point-min) (point-max))) + (p4-make-depot-list-buffer + (concat "*P4 Files: (" (p4-current-client) ") " (car args) "*")))) + + +(defvar p4-server-version-cache nil) + +(defun p4-get-server-version () + "To get the version number of the p4 server." + (let ((p4-port (p4-current-server-port)) + ser-ver pmin) + (setq ser-ver (cdr (assoc p4-port p4-server-version-cache))) + (if (not ser-ver) + (save-excursion + (get-buffer-create p4-output-buffer-name) + (set-buffer p4-output-buffer-name) + (goto-char (point-max)) + (setq pmin (point)) + (if (zerop (call-process (p4-check-p4-executable) nil t nil "info")) + (progn + (goto-char pmin) + (re-search-forward + "^Server version: .*\/.*\/\\(\\([0-9]+\\)\.[0-9]+\\)\/.*(.*)$") + (setq ser-ver (string-to-number (match-string 2))) + (setq p4-server-version-cache (cons (cons p4-port ser-ver) + p4-server-version-cache)) + (delete-region pmin (point-max)))))) + ser-ver)) + +(defun p4-get-client-root (client-name) + "To get the current value of Client's root type \\[p4-get-client-root]. + This can be used by any other macro that requires this value." + (let (p4-client-root pmin) + (save-excursion + (get-buffer-create p4-output-buffer-name) + (set-buffer p4-output-buffer-name) + (goto-char (point-max)) + (setq pmin (point)) + (if (zerop (call-process + (p4-check-p4-executable) nil t nil "client" "-o" client-name)) + (progn + (goto-char pmin) + (re-search-forward "^Root:[ \t]+\\(.*\\)$") + (setq p4-client-root (p4-canonize-client-root (match-string 1))) + (delete-region pmin (point-max))))) + p4-client-root)) + +(defun p4-canonize-client-root (p4-client-root) + "Canonizes client root" + (let ((len (length p4-client-root))) + ;; For Windows, since the client root may be terminated with + ;; a \ as in c:\ or drive:\foo\bar\, we need to strip the + ;; trailing \ . + (if (and (p4-windows-os) + (> len 1) + (equal (substring p4-client-root (1- len) len) "\\")) + (setq p4-client-root (substring p4-client-root 0 (1- len)))) + p4-client-root)) + +(defun p4-map-depot-files (file-list) + "Map a list of files in the depot on the current client. +Return a list of pairs, where each pair consists of a depot +name and a client name." + (let (file-map) + (while file-list + (let (sub-list (arg-len 0) elt) + (while (and file-list (< arg-len p4-exec-arg-len-max)) + (setq elt (car file-list)) + (setq file-list (cdr file-list)) + (setq sub-list (cons elt sub-list)) + (setq arg-len (+ arg-len (length elt) 1))) + (setq file-map (append file-map + (p4-map-depot-files-int sub-list))))) + file-map)) + +(defun p4-map-depot-files-int (file-list) + (let* ((current-client (p4-current-client)) + (client-root (p4-get-client-root current-client)) + (re-current-client (regexp-quote current-client)) + (re-client-root (regexp-quote client-root)) + files pmin) + (save-excursion + (get-buffer-create p4-output-buffer-name) + (set-buffer p4-output-buffer-name) + (goto-char (point-max)) + (setq pmin (point)) + (insert "\n") + (apply 'call-process + (p4-check-p4-executable) nil t nil "where" file-list) + (goto-char pmin) + (if (< (p4-get-server-version) 98) + (while (re-search-forward + (concat "^\\([^\n]+\\) //" re-current-client + "\\(.*\\)$") nil t) + (setq files (cons + (cons + (match-string 1) + (concat client-root (match-string 2))) + files))) + (while (re-search-forward + (concat "^\\([^\n]+\\) //" re-current-client + "\\([^\n]+\\) \\(" re-client-root ".*\\)$") nil t) + (setq files (cons + (cons + (match-string 1) (match-string 3)) files)))) + (delete-region pmin (point-max))) + files)) + +(make-face 'p4-depot-unmapped-face) +(set-face-foreground 'p4-depot-unmapped-face "grey30") + +(make-face 'p4-depot-deleted-face) +(set-face-foreground 'p4-depot-deleted-face "red") + +(make-face 'p4-depot-added-face) +(set-face-foreground 'p4-depot-added-face "blue") + +(make-face 'p4-depot-branch-op-face) +(set-face-foreground 'p4-depot-branch-op-face "blue4") + +(defun p4-make-depot-list-buffer (bufname &optional print-buffer) + "Take the p4-output-buffer-name buffer, rename it to bufname, and +make all depot file names active, so that clicking them opens +the corresponding client file." + (let (args files depot-regexp) + (set-buffer p4-output-buffer-name) + (goto-char (point-min)) + (setq depot-regexp + (if print-buffer + "\\(^\\)\\(//[^/@# ][^/@#]*/[^@#]+\\)#[0-9]+ - " + "^\\(\\.\\.\\. [^/\n]*\\|==== \\)?\\(//[^/@# ][^/@#]*/[^#\n]*\\)")) + (while (re-search-forward depot-regexp nil t) + (setq args (cons (match-string 2) args))) + (setq files (p4-map-depot-files args)) + (get-buffer-create bufname);; We do these two lines + (kill-buffer bufname);; to ensure no duplicates + (set-buffer p4-output-buffer-name) + (rename-buffer bufname t) + (goto-char (point-min)) + (while (re-search-forward depot-regexp nil t) + (let ((p4-client-file (cdr (assoc (match-string 2) files))) + (p4-depot-file (match-string 2)) + (start (match-beginning 2)) + (end (match-end 2)) + (branching-op-p (and (match-string 1) + (string-match "\\.\\.\\. \\.\\.\\..*" + (match-string 1)))) + prop-list) + (if (and p4-client-file + (file-readable-p p4-client-file)) + (setq prop-list (list (cons 'link-client-name + p4-client-file))) + (setq prop-list (list (cons 'link-depot-name + p4-depot-file)))) + ;; some kind of operation related to branching/integration + (if branching-op-p + (setq prop-list (append (list + (cons 'history-for p4-depot-file) + (cons 'face + 'p4-depot-branch-op-face)) + prop-list))) + (cond + ((not p4-client-file) + (p4-set-extent-properties + start end + (append (list (cons 'face 'p4-depot-unmapped-face)) + prop-list))) + ((save-excursion + (goto-char end) + (looking-at ".* deleted?[ \n]")) + (p4-set-extent-properties + start end + (append (list (cons 'face 'p4-depot-deleted-face)) + prop-list))) + ((save-excursion + (goto-char end) + (looking-at ".* \\(add\\|branch\\)\\(ed\\)?[ \n]")) + (p4-create-active-link + start end + (append (list (cons 'face 'p4-depot-added-face)) + prop-list))) + (t + (p4-create-active-link start end prop-list))))) + (use-local-map p4-opened-map) + (setq buffer-read-only t) + (p4-move-buffer-point-to-top bufname))) + +;; The p4 print command +(defp4cmd p4-print () + "print" "To print a depot file to a buffer, type \\[p4-print].\n" + (interactive) + (let ((arg-string (p4-buffer-file-name-2)) + (rev (get-char-property (point) 'rev)) + (change (get-char-property (point) 'change))) + (cond (rev + (setq arg-string (concat arg-string "#" rev))) + (change + (setq arg-string (concat arg-string "@" change)))) + (if (or current-prefix-arg (not arg-string)) + (setq arg-string (p4-make-list-from-string + (p4-read-arg-string "p4 print: " arg-string))) + (setq arg-string (list arg-string))) + (p4-noinput-buffer-action "print" nil t arg-string) + (p4-activate-print-buffer "*P4 print*" t))) + +;; Insert text in a buffer, but make sure that the inserted text doesn't +;; inherit any properties from surrounding text. This is needed for xemacs +;; because the insert function makes the inserted text inherit properties. +(defun p4-insert-no-properties (str) + (let ((start (point)) + end) + (insert str) + (setq end (point)) + (set-text-properties start end nil))) + +(defun p4-font-lock-buffer (buf-name) + (save-excursion + (let (file-name (first-line "")) + (set-buffer buf-name) + (goto-char (point-min)) + (if (looking-at "^//[^#@]+/\\([^/#@]+\\)") + (progn + (setq file-name (match-string 1)) + (forward-line 1) + (setq first-line (buffer-substring (point-min) (point))) + (delete-region (point-min) (point)))) + (setq buffer-file-name file-name) + (set-auto-mode) + (setq buffer-file-name nil) + (condition-case nil + (font-lock-fontify-buffer) + (error nil)) + (fundamental-mode) + (if (and p4-running-emacs + (boundp 'hilit-auto-rehighlight)) + (setq hilit-auto-rehighlight nil)) + (goto-char (point-min)) + (p4-insert-no-properties first-line)))) + +(defun p4-activate-print-buffer (buffer-name print-buffer) + (if print-buffer + (p4-font-lock-buffer p4-output-buffer-name)) + (p4-make-depot-list-buffer buffer-name print-buffer) + (let ((depot-regexp + (if print-buffer + "^\\(//[^/@# ][^/@#]*/\\)[^@#]+#[0-9]+ - " + "^\\(//[^/@# ][^/@#]*/\\)"))) + (save-excursion + (set-buffer buffer-name) + (setq buffer-read-only nil) + (goto-char (point-min)) + (while (re-search-forward depot-regexp nil t) + (let ((link-client-name (get-char-property (match-end 1) + 'link-client-name)) + (link-depot-name (get-char-property (match-end 1) + 'link-depot-name)) + (start (match-beginning 1)) + (end (point-max))) + (save-excursion + (if (re-search-forward depot-regexp nil t) + (setq end (match-beginning 1)))) + (if link-client-name + (p4-set-extent-properties start end + (list (cons 'block-client-name + link-client-name)))) + (if link-depot-name + (p4-set-extent-properties start end + (list (cons 'block-depot-name + link-depot-name)))))) + (setq buffer-read-only t)))) + +(defconst p4-blame-change-regex + (concat "^\\.\\.\\. #" "\\([0-9]+\\)" ;; revision + "\\s-+change\\s-+" "\\([0-9]+\\)" ;; change + "\\s-+" "\\([^ \t]+\\)" ;; type + "\\s-+on\\s-+" "\\([^ \t]+\\)" ;; date + "\\s-+by\\s-+" "\\([^ \t]+\\)" ;; author + "@")) + +(defconst p4-blame-branch-regex + "^\\.\\.\\. \\.\\.\\. branch from \\(//[^#]*\\)#") + +(defconst p4-blame-revision-regex + (concat "^\\([0-9]+\\),?" + "\\([0-9]*\\)" + "\\([acd]\\)" + "\\([0-9]+\\),?" + "\\([0-9]*\\)")) + +(defconst p4-blame-index-regex + (concat " *\\([0-9]+\\)" ;; change + " *\\([0-9]+\\)" ;; revision + " *\\([0-9]+/[0-9]+/[0-9]+\\)" ;; date + "\\s-+\\([^:]*\\)" ;; author + ":")) + +(defconst P4-REV 0) +(defconst P4-DATE 1) +(defconst P4-AUTH 2) +(defconst P4-FILE 3) + +(defun p4-blame () + "To Print a depot file with revision history to a buffer, +type \\[p4-blame]" + (interactive) + (let ((arg-string (p4-buffer-file-name-2)) + (rev (get-char-property (point) 'rev)) + (change (get-char-property (point) 'change))) + (cond (rev + (setq arg-string (concat arg-string "#" rev))) + (change + (setq arg-string (concat arg-string "@" change)))) + (if (or current-prefix-arg (not arg-string)) + (setq arg-string (p4-read-arg-string "p4 print-revs: " arg-string))) + (p4-blame-int arg-string))) + +(defalias 'p4-print-with-rev-history 'p4-blame) + +(defun p4-blame-int (file-spec) + (get-buffer-create p4-output-buffer-name);; We do these two lines + (kill-buffer p4-output-buffer-name) ;; to ensure no duplicates + (let ((file-name file-spec) + (buffer (get-buffer-create p4-output-buffer-name)) + head-name ;; file spec of the head revision for this blame assignment + branch-p ;; have we tracked into a branch? + cur-file ;; file name of the current branch during blame assignment + change ch-alist fullname head-rev headseen) + + ;; we asked for blame constrained by a change number + (if (string-match "\\(.*\\)@\\([0-9]+\\)" file-spec) + (progn + (setq file-name (match-string 1 file-spec)) + (setq change (string-to-int (match-string 2 file-spec))))) + + ;; we asked for blame constrained by a revision + (if (string-match "\\(.*\\)#\\([0-9]+\\)" file-spec) + (progn + (setq file-name (match-string 1 file-spec)) + (setq head-rev (string-to-int (match-string 2 file-spec))))) + + ;; make sure the filespec is unambiguous + (p4-exec-p4 buffer (list "files" file-name) t) + (save-excursion + (set-buffer buffer) + (if (> (count-lines (point-min) (point-max)) 1) + (error "File pattern maps to more than one file."))) + + ;; get the file change history: + (p4-exec-p4 buffer (list "filelog" "-i" file-spec) t) + (setq fullname (p4-read-depot-output buffer) + cur-file fullname + head-name fullname) + + ;; parse the history: + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (while (< (point) (point-max)) + + ;; record the current file name (and the head file name, + ;; if we have not yet seen one): + (if (looking-at "^\\(//.*\\)$") + (setq cur-file (match-string 1))) + + ;; a non-branch change: + (if (looking-at p4-blame-change-regex) + (let ((rev (string-to-int (match-string 1))) + (ch (string-to-int (match-string 2))) + (op (match-string 3)) + (date (match-string 4)) + (author (match-string 5))) + (cond + ;; after the change constraint, OR + ;; after the revision constraint _for this file_ + ;; [remember, branches complicate this]: + ((or (and change (< change ch)) + (and head-rev (< head-rev rev) + (string= head-name cur-file))) nil) + + ;; file has been deleted, can't assign blame: + ((string= op "delete") + (if (not headseen) (goto-char (point-max)))) + + ;; OK, we actually want to look at this one: + (t + (setq ch-alist + (cons + (cons ch (list rev date author cur-file)) ch-alist)) + (if (not head-rev) (setq head-rev rev)) + (setq headseen t)) )) + + ;; not if we have entered a branch (this used to be used, isn't + ;; right now - maybe again later: + (if (and headseen (looking-at p4-blame-branch-regex)) + (setq branch-p t)) ) + (forward-line))) + + (if (< (length ch-alist) 1) + (error "Head revision not available")) + + (let ((base-ch (int-to-string (caar ch-alist))) + (ch-buffer (get-buffer-create "p4-ch-buf")) + (tmp-alst (copy-alist ch-alist))) + (p4-exec-p4 ch-buffer + (list "print" "-q" (concat cur-file "@" base-ch)) t) + (save-excursion + (set-buffer ch-buffer) + (goto-char (point-min)) + (while (re-search-forward ".*\n" nil t) + (replace-match (concat base-ch "\n")))) + (while (> (length tmp-alst) 1) + (let ((ch-1 (car (car tmp-alst))) + (ch-2 (car (cadr tmp-alst))) + (file1 (nth P4-FILE (cdr (car tmp-alst)))) + (file2 (nth P4-FILE (cdr (cadr tmp-alst)))) + ins-string) + (setq ins-string (format "%d\n" ch-2)) + (p4-exec-p4 buffer (list "diff2" + (format "%s@%d" file1 ch-1) + (format "%s@%d" file2 ch-2)) t) + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (while (re-search-backward p4-blame-revision-regex nil t) + (let ((la (string-to-int (match-string 1))) + (lb (string-to-int (match-string 2))) + (op (match-string 3)) + (ra (string-to-int (match-string 4))) + (rb (string-to-int (match-string 5)))) + (if (= lb 0) + (setq lb la)) + (if (= rb 0) + (setq rb ra)) + (cond ((string= op "a") + (setq la (1+ la))) + ((string= op "d") + (setq ra (1+ ra)))) + (save-excursion + (set-buffer ch-buffer) + (goto-line la) + (let ((beg (point))) + (forward-line (1+ (- lb la))) + (delete-region beg (point))) + (while (<= ra rb) + (insert ins-string) + (setq ra (1+ ra))))))) + (setq tmp-alst (cdr tmp-alst)))) + (p4-noinput-buffer-action "print" nil t + (list (format "%s#%d" fullname head-rev)) + t) + (p4-font-lock-buffer p4-output-buffer-name) + (let (line cnum (old-cnum 0) change-data + xth-rev xth-date xth-auth xth-file) + (save-excursion + (set-buffer buffer) + (goto-line 2) + (move-to-column 0) + (p4-insert-no-properties "Change Rev Date Author\n") + (while (setq line (p4-read-depot-output ch-buffer)) + (setq cnum (string-to-int line)) + (if (= cnum old-cnum) + (p4-insert-no-properties (format "%29s : " "")) + + ;; extract the change data from our alist: remember, + ;; `eq' works for integers so we can use assq here: + (setq change-data (cdr (assq cnum ch-alist)) + xth-rev (nth P4-REV change-data) + xth-date (nth P4-DATE change-data) + xth-auth (nth P4-AUTH change-data) + xth-file (nth P4-FILE change-data)) + + (p4-insert-no-properties + (format "%6d %4d %10s %7s: " cnum xth-rev xth-date xth-auth)) + (move-to-column 0) + (if (looking-at p4-blame-index-regex) + (let ((nth-cnum (match-string 1)) + (nth-revn (match-string 2)) + (nth-user (match-string 4))) + (p4-create-active-link (match-beginning 1) + (match-end 1) + (list (cons 'change nth-cnum))) + ;; revision needs to be linked to a file now that we + ;; follow integrations (branches): + (p4-create-active-link (match-beginning 2) + (match-end 2) + (list (cons 'rev nth-revn) + (cons 'link-depot-name xth-file))) + (p4-create-active-link (match-beginning 4) + (match-end 4) + (list (cons 'user nth-user))) + ;; truncate the user name: + (let ((start (+ (match-beginning 4) 7)) + (end (match-end 4))) + (if (> end start) + (delete-region start end)))))) + (setq old-cnum cnum) + (forward-line)))) + + (kill-buffer ch-buffer)) + (let ((buffer-name (concat "*P4 print-revs " file-name "*"))) + (p4-activate-print-buffer buffer-name nil) + (save-excursion + (set-buffer buffer-name) + (setq truncate-lines t) + (use-local-map p4-print-rev-map))))) + +;; The p4 refresh command +(defp4cmd p4-refresh () + "sync" "Refresh the contents of an unopened file. \\[p4-refresh]. + +This is equivalent to \"sync -f\" +" + (interactive) + (let ((args (p4-buffer-file-name))) + (if (or current-prefix-arg (not args)) + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 refresh: "))) + (setq args (list args))) + (p4-noinput-buffer-action "refresh" nil t args) + (p4-refresh-files-in-buffers) + (p4-make-depot-list-buffer + (concat "*P4 Refresh: (" (p4-current-client) ") " (car args) "*")))) + +;; The p4 get/sync command +(defp4cmd p4-sync () + "sync" + "To synchronise the local view with the depot, type \\[p4-get].\n" + (interactive) + (p4-get)) + +(defp4cmd p4-get () + "sync" + "To synchronise the local view with the depot, type \\[p4-get].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string (p4-read-arg-string "p4 get: ")))) + (p4-noinput-buffer-action "get" nil t args) + (p4-refresh-files-in-buffers) + (p4-make-depot-list-buffer + (concat "*P4 Get: (" (p4-current-client) ") " (car args) "*")))) + +;; The p4 have command +(defp4cmd p4-have () + "have" "To list revisions last gotten, type \\[p4-have].\n" + (interactive) + (let ((args (list "..."))) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 have: " (p4-buffer-file-name-2))))) + (p4-noinput-buffer-action "have" nil t args) + (p4-make-depot-list-buffer + (concat "*P4 Have: (" (p4-current-client) ") " (car args) "*")))) + +;; The p4 changes command +(defp4cmd p4-changes () + "changes" "To list changes, type \\[p4-changes].\n" + (interactive) + (let ((arg-list (list "-m" "200" "..."))) + (if current-prefix-arg + (setq arg-list (p4-make-list-from-string + (p4-read-arg-string "p4 changes: " "-m 200")))) + (p4-file-change-log "changes" arg-list))) + +;; The p4 help command +(defp4cmd p4-help (arg) + "help" "To print help message, type \\[p4-help]. + +Argument ARG command for which help is needed. +" + (interactive (list (p4-make-list-from-string + (p4-read-arg-string "Help on which command: " + nil "help")))) + (p4-noinput-buffer-action "help" nil t arg) + (p4-make-basic-buffer "*P4 help*")) + +(defun p4-make-basic-buffer (buf-name &optional map) + "rename `p4-output-buffer-name' to buf-name \(which will be killed first if +it already exists\), set its local map to map, if specified, or +`p4-basic-map' otherwise. Makes the buffer read only." + (get-buffer-create buf-name) + (kill-buffer buf-name) + (set-buffer p4-output-buffer-name) + (goto-char (point-min)) + (rename-buffer buf-name t) + (use-local-map (if (keymapp map) map p4-basic-map)) + (setq buffer-read-only t) + (p4-move-buffer-point-to-top buf-name)) + +;; The p4 info command +(defp4cmd p4-info () + "info" "To print out client/server information, type \\[p4-info].\n" + (interactive) + (p4-noinput-buffer-action "info" nil t) + (p4-make-basic-buffer "*P4 info*")) + +;; The p4 integrate command +(defp4cmd p4-integ () + "integ" "To schedule integrations between branches, type \\[p4-integ].\n" + (interactive) + (let ((args (p4-make-list-from-string + (p4-read-arg-string "p4 integ: " "-b ")))) + (p4-noinput-buffer-action "integ" nil t args) + (p4-make-depot-list-buffer "*P4 integ*"))) + +(defp4cmd p4-resolve () + "resolve" + "To merge open files with other revisions or files, type \\[p4-resolve].\n" + (interactive) + (let (buffer args (buf-name "*p4 resolve*")) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 resolve: " nil)))) + (setq buffer (get-buffer buf-name)) + (if (and (buffer-live-p buffer) + (not (comint-check-proc buffer))) + (save-excursion + (let ((cur-dir default-directory)) + (set-buffer buffer) + (cd cur-dir) + (goto-char (point-max)) + (insert "\n--------\n\n")))) + (setq args (cons "resolve" args)) + (setq buffer (apply 'make-comint "p4 resolve" p4-executable nil args)) + (set-buffer buffer) + (comint-mode) + (display-buffer buffer) + (select-window (get-buffer-window buffer)) + (goto-char (point-max)))) + +(defp4cmd p4-rename () + "rename" "To rename a file in the depot, type \\[p4-rename]. + +This command will execute the integrate/delete commands automatically. +" + (interactive) + (let (from-file to-file) + (setq from-file (p4-read-arg-string "rename from: " (p4-buffer-file-name-2))) + (setq to-file (p4-read-arg-string "rename to: " (p4-buffer-file-name-2))) + (p4-noinput-buffer-action "integ" nil t (list from-file to-file)) + (p4-exec-p4 (get-buffer-create p4-output-buffer-name) + (list "delete" from-file) + nil))) + +(defun p4-scroll-down-1-line () + "Scroll down one line" + (interactive) + (scroll-down 1)) + +(defun p4-scroll-up-1-line () + "Scroll up one line" + (interactive) + (scroll-up 1)) + +(defun p4-scroll-down-1-window () + "Scroll down one window" + (interactive) + (scroll-down + (- (window-height) next-screen-context-lines))) + +(defun p4-scroll-up-1-window () + "Scroll up one window" + (interactive) + (scroll-up + (- (window-height) next-screen-context-lines))) + +(defun p4-top-of-buffer () + "Top of buffer" + (interactive) + (goto-char (point-min))) + +(defun p4-bottom-of-buffer () + "Bottom of buffer" + (interactive) + (goto-char (point-max))) + +(defun p4-delete-other-windows () + "Make buffer full height" + (interactive) + (delete-other-windows)) + +(defun p4-goto-next-diff () + "Next diff" + (interactive) + (goto-char (window-start)) + (if (= (point) (point-max)) + (error "At bottom")) + (forward-line 1) + (re-search-forward "^====" nil "") + (beginning-of-line) + (set-window-start (selected-window) (point))) + +(defun p4-goto-prev-diff () + "Previous diff" + (interactive) + (if (= (point) (point-min)) + (error "At top")) + (goto-char (window-start)) + (re-search-backward "^====" nil "") + (set-window-start (selected-window) (point))) + +(defun p4-next-depot-file () + "Next file" + (interactive) + (goto-char (window-start)) + (if (= (point) (point-max)) + (error "At bottom")) + (forward-line 1) + (re-search-forward "^//[^/@# ][^/@#]*/[^@#]+#[0-9]+ - " nil "") + (beginning-of-line) + (set-window-start (selected-window) (point))) + +(defun p4-prev-depot-file () + "Previous file" + (interactive) + (if (= (point) (point-min)) + (error "At top")) + (goto-char (window-start)) + (re-search-backward "^//[^/@# ][^/@#]*/[^@#]+#[0-9]+ - " nil "") + (set-window-start (selected-window) (point))) + + +(defun p4-next-depot-diff () + "Next diff" + (interactive) + (goto-char (window-start)) + (if (= (point) (point-max)) + (error "At bottom")) + (forward-line 1) + (re-search-forward "^\\(@@\\|\\*\\*\\* \\|[0-9]+[,acd]\\)" nil "") + (beginning-of-line) + (set-window-start (selected-window) (point))) + +(defun p4-prev-depot-diff () + "Previous diff" + (interactive) + (if (= (point) (point-min)) + (error "At top")) + (goto-char (window-start)) + (re-search-backward "^\\(@@\\|\\*\\*\\* \\|[0-9]+[,acd]\\)" nil "") + (set-window-start (selected-window) (point))) + +(defun p4-moveto-print-rev-column (old-column) + (let ((colon (save-excursion + (move-to-column 0) + (if (looking-at "[^:\n]*:") + (progn + (goto-char (match-end 0)) + (current-column)) + 0)))) + (move-to-column old-column) + (if (and (< (current-column) colon) + (re-search-forward "[^ ][ :]" nil t)) + (goto-char (match-beginning 0))))) + +(defun p4-next-change-rev-line () + "Next change/revision line" + (interactive) + (let ((c (current-column))) + (move-to-column 1) + (re-search-forward "^ *[0-9]+ +[0-9]+[^:]+:" nil "") + (p4-moveto-print-rev-column c))) + +(defun p4-prev-change-rev-line () + "Previous change/revision line" + (interactive) + (let ((c (current-column))) + (forward-line -1) + (move-to-column 32) + (re-search-backward "^ *[0-9]+ +[0-9]+[^:]*:" nil "") + (p4-moveto-print-rev-column c))) + +(defun p4-toggle-line-wrap () + "Toggle line wrap mode" + (interactive) + (setq truncate-lines (not truncate-lines)) + (save-window-excursion + (recenter))) + +(defun p4-quit-current-buffer (pnt) + "Quit a buffer" + (interactive "d") + (if (not (one-window-p)) + (delete-window) + (bury-buffer))) + +(defun p4-buffer-mouse-clicked (event) + "Function to translate the mouse clicks in a P4 filelog buffer to +character events" + (interactive "e") + (let (win pnt) + (cond (p4-running-xemacs + (setq win (event-window event)) + (setq pnt (event-point event))) + (p4-running-emacs + (setq win (posn-window (event-end event))) + (setq pnt (posn-point (event-start event))))) + (select-window win) + (goto-char pnt) + (p4-buffer-commands pnt))) + +(defun p4-buffer-mouse-clicked-3 (event) + "Function to translate the mouse clicks in a P4 filelog buffer to +character events" + (interactive "e") + (let (win pnt) + (cond (p4-running-xemacs + (setq win (event-window event)) + (setq pnt (event-point event))) + (p4-running-emacs + (setq win (posn-window (event-end event))) + (setq pnt (posn-point (event-start event))))) + (select-window win) + (goto-char pnt) + (let ((link-name (or (get-char-property pnt 'link-client-name) + (get-char-property pnt 'link-depot-name))) + (rev (get-char-property pnt 'rev))) + (cond (link-name + (p4-diff)) + (rev + (p4-diff2 rev "#head")) + (t + (error "No file to diff!")))))) + +(defun p4-buffer-commands (pnt) + "Function to get a given property and do the appropriate command on it" + (interactive "d") + (let ((rev (get-char-property pnt 'rev)) + (change (get-char-property pnt 'change)) + (action (get-char-property pnt 'action)) + (user (get-char-property pnt 'user)) + (client (get-char-property pnt 'client)) + (label (get-char-property pnt 'label)) + (branch (get-char-property pnt 'branch)) + (filename (p4-buffer-file-name-2))) + (cond ((and (not action) rev) + (let ((fn1 (concat filename "#" rev))) + (p4-noinput-buffer-action "print" nil t (list fn1)) + (p4-activate-print-buffer "*P4 print*" t))) + (action + (let* ((rev2 (int-to-string (1- (string-to-int rev)))) + (fn1 (concat filename "#" rev)) + (fn2 (concat filename "#" rev2))) + (if (> (string-to-int rev2) 0) + (progn + (p4-noinput-buffer-action + "diff2" nil t + (append (p4-make-list-from-string + p4-default-diff-options) + (list fn2 fn1))) + (p4-activate-diff-buffer "*P4 diff*")) + (error "There is no earlier revision to diff.")))) + (change (p4-describe-internal + (append (p4-make-list-from-string p4-default-diff-options) + (list change)))) + (user (p4-async-process-command "user" nil + (concat + "*P4 User: " user "*") + "user" (list user))) + (client (p4-async-process-command + "client" "Description:\n\t" + (concat "*P4 Client: " client "*") "client" (list client))) + (label (p4-label (list label))) + (branch (p4-branch (list branch))) + + ;; Check if a "filename link" or an active "diff buffer area" was + ;; selected. + (t + (let ((link-client-name (get-char-property pnt 'link-client-name)) + (link-depot-name (get-char-property pnt 'link-depot-name)) + (block-client-name (get-char-property pnt 'block-client-name)) + (block-depot-name (get-char-property pnt 'block-depot-name)) + (p4-history-for (get-char-property pnt 'history-for)) + (first-line (get-char-property pnt 'first-line)) + (start (get-char-property pnt 'start))) + (cond + (p4-history-for + (p4-file-change-log "filelog" (list p4-history-for))) + ((or link-client-name link-depot-name) + (p4-find-file-or-print-other-window + link-client-name link-depot-name)) + ((or block-client-name block-depot-name) + (if first-line + (let ((c (max 0 (- pnt + (save-excursion + (goto-char pnt) + (beginning-of-line) + (point)) + 1))) + (r first-line)) + (save-excursion + (goto-char start) + (while (re-search-forward "^[ +>].*\n" pnt t) + (setq r (1+ r)))) + (p4-find-file-or-print-other-window + block-client-name block-depot-name) + (goto-line r) + (if (not block-client-name) + (forward-line 1)) + (beginning-of-line) + (goto-char (+ (point) c))) + (p4-find-file-or-print-other-window + block-client-name block-depot-name))) + (t + (error "There is no file at that cursor location!")))))))) + +(defun p4-find-file-or-print-other-window (client-name depot-name) + (if client-name + (find-file-other-window client-name) + (p4-noinput-buffer-action "print" nil t + (list depot-name)) + (p4-activate-print-buffer depot-name t) + (other-window 1))) + +(defun p4-find-file-other-window () + "Open/print file" + (interactive) + (let ((link-client-name (get-char-property (point) 'link-client-name)) + (link-depot-name (get-char-property (point) 'link-depot-name)) + (block-client-name (get-char-property (point) 'block-client-name)) + (block-depot-name (get-char-property (point) 'block-depot-name))) + (cond ((or link-client-name link-depot-name) + (p4-find-file-or-print-other-window + link-client-name link-depot-name) + (other-window 1)) + ((or block-client-name block-depot-name) + (p4-find-file-or-print-other-window + block-client-name block-depot-name) + (other-window 1))))) + +(defun p4-filelog-short-format () + "Short format" + (interactive) + (setq buffer-invisibility-spec t) + (redraw-display)) + +(defun p4-filelog-long-format () + "Long format" + (interactive) + (setq buffer-invisibility-spec (list)) + (redraw-display)) + +(defun p4-scroll-down-1-line-other-w () + "Scroll other window down one line" + (interactive) + (scroll-other-window -1)) + +(defun p4-scroll-up-1-line-other-w () + "Scroll other window up one line" + (interactive) + (scroll-other-window 1)) + +(defun p4-scroll-down-1-window-other-w () + "Scroll other window down one window" + (interactive) + (scroll-other-window + (- next-screen-context-lines (window-height)))) + +(defun p4-scroll-up-1-window-other-w () + "Scroll other window up one window" + (interactive) + (scroll-other-window + (- (window-height) next-screen-context-lines))) + +(defun p4-top-of-buffer-other-w () + "Top of buffer, other window" + (interactive) + (other-window 1) + (goto-char (point-min)) + (other-window -1)) + +(defun p4-bottom-of-buffer-other-w () + "Bottom of buffer, other window" + (interactive) + (other-window 1) + (goto-char (point-max)) + (other-window -1)) + +(defun p4-goto-next-change () + "Next change" + (interactive) + (let ((c (current-column))) + (forward-line 1) + (while (get-char-property (point) 'invisible) + (forward-line 1)) + (move-to-column c))) + +(defun p4-goto-prev-change () + "Previous change" + (interactive) + (let ((c (current-column))) + (forward-line -1) + (while (get-char-property (point) 'invisible) + (forward-line -1)) + (move-to-column c))) + + +;; Activate special handling for a buffer generated with a diff-like command +(make-face 'p4-diff-file-face) +(set-face-background 'p4-diff-file-face "gray90") + +(make-face 'p4-diff-head-face) +(set-face-background 'p4-diff-head-face "gray95") + +(make-face 'p4-diff-ins-face) +(set-face-foreground 'p4-diff-ins-face "blue") + +(make-face 'p4-diff-del-face) +(set-face-foreground 'p4-diff-del-face "red") + +(make-face 'p4-diff-change-face) +(set-face-foreground 'p4-diff-change-face "dark green") + +(defun p4-buffer-set-face-property (regexp face-property) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (let ((start (match-beginning 0)) + (end (match-end 0))) + (p4-set-extent-properties start end + (list (cons 'face face-property))))))) + +(defun p4-activate-diff-buffer (buffer-name) + (p4-make-depot-list-buffer buffer-name) + (save-excursion + (set-buffer buffer-name) + (setq buffer-read-only nil) + (if p4-colorized-diffs + (progn + (p4-buffer-set-face-property "^=.*\n" 'p4-diff-file-face) + (p4-buffer-set-face-property "^[@*].*" 'p4-diff-head-face) + (p4-buffer-set-face-property "^\\([+>].*\n\\)+" 'p4-diff-ins-face) + (p4-buffer-set-face-property "^\\([-<].*\n\\)+" 'p4-diff-del-face) + (p4-buffer-set-face-property "^\\(!.*\n\\)+" 'p4-diff-change-face))) + + (goto-char (point-min)) + (while (re-search-forward "^\\(==== //\\).*\n" + nil t) + (let* ((link-client-name (get-char-property (match-end 1) 'link-client-name)) + (link-depot-name (get-char-property (match-end 1) 'link-depot-name)) + (start (match-beginning 0)) + (end (save-excursion + (if (re-search-forward "^==== " nil t) + (match-beginning 0) + (point-max))))) + (if link-client-name + (p4-set-extent-properties start end + (list (cons 'block-client-name + link-client-name)))) + (if link-depot-name + (p4-set-extent-properties start end + (list (cons 'block-depot-name + link-depot-name)))))) + + (goto-char (point-min)) + (while (re-search-forward + (concat "^[@0-9].*\\([cad+]\\)\\([0-9]*\\).*\n" + "\\(\\(\n\\|[^@0-9\n].*\n\\)*\\)") nil t) + (let ((first-line (string-to-int (match-string 2))) + (start (match-beginning 3)) + (end (match-end 3))) + (p4-set-extent-properties start end + (list (cons 'first-line first-line) + (cons 'start start))))) + + (goto-char (point-min)) + (let ((stop + (if (re-search-forward "^\\(\\.\\.\\.\\|====\\)" nil t) + (match-beginning 0) + (point-max)))) + (p4-find-change-numbers buffer-name (point-min) stop)) + + (use-local-map p4-diff-map) + (setq buffer-read-only t))) + + +;; The p4 describe command +(defp4cmd p4-describe () + "describe" "To get a description for a change number, type \\[p4-describe].\n" + (interactive) + (let ((arg-string (p4-make-list-from-string + (read-string "p4 describe: " + (concat p4-default-diff-options " "))))) + (p4-describe-internal arg-string))) + +;; Internal version of the p4 describe command +(defun p4-describe-internal (arg-string) + (p4-noinput-buffer-action + "describe" nil t arg-string) + (p4-activate-diff-buffer + (concat "*P4 describe: " (p4-list-to-string arg-string) "*"))) + +;; The p4 opened command +(defp4cmd p4-opened () + "opened" + "To display list of files opened for pending change, type \\[p4-opened].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 opened: " + (p4-buffer-file-name-2))))) + (p4-opened-internal args))) + +(defun p4-opened-internal (args) + (let ((p4-client (p4-current-client))) + (p4-noinput-buffer-action "opened" nil t args) + (p4-make-depot-list-buffer (concat "*Opened Files: " p4-client "*")))) + +(defun p4-update-opened-list () + (if (get-buffer-window (concat "*Opened Files: " (p4-current-client) "*")) + (progn + (setq current-prefix-arg nil) + (p4-opened-internal nil)))) + +(defun p4-regexp-create-links (buffer-name regexp property) + (save-excursion + (set-buffer buffer-name) + (setq buffer-read-only nil) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (let ((start (match-beginning 1)) + (end (match-end 1)) + (str (match-string 1))) + (p4-create-active-link start end (list (cons property str))))) + (setq buffer-read-only t))) + +;; The p4 users command +(defp4cmd p4-users () + "users" "To display list of known users, type \\[p4-users].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 users: " nil "user")))) + (p4-noinput-buffer-action "users" nil t args)) + (p4-make-basic-buffer "*P4 users*") + (p4-regexp-create-links "*P4 users*" "^\\([^ ]+\\).*\n" 'user)) + +;; The p4 jobs command +(defp4cmd p4-jobs () + "jobs" "To display list of jobs, type \\[p4-jobs].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string (p4-read-arg-string "p4 jobs: ")))) + (p4-noinput-buffer-action "jobs" nil t args)) + (p4-make-basic-buffer "*P4 jobs*")) + +;; The p4 fix command +(defp4cmd p4-fix () + "fix" "To mark jobs as being fixed by a changelist number, type \\[p4-fix].\n" + (interactive) + (let ((args (p4-make-list-from-string (p4-read-arg-string "p4 fix: " + nil "job")))) + (p4-noinput-buffer-action "fix" nil t args))) + +;; The p4 fixes command +(defp4cmd p4-fixes () + "fixes" "To list what changelists fix what jobs, type \\[p4-fixes].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string (p4-read-arg-string "p4 fixes: ")))) + (p4-noinput-buffer-action "fixes" nil t args) + (p4-make-basic-buffer "*P4 fixes*"))) + +;; The p4 where command +(defp4cmd p4-where () + "where" + "To show how local file names map into depot names, type \\[p4-where].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 where: " + (p4-buffer-file-name-2))))) + (p4-noinput-buffer-action "where" nil 's args))) + + +(defun p4-async-process-command (p4-this-command &optional + p4-regexp + p4-this-buffer + p4-out-command + p4-in-args + p4-out-args) + "Internal function to call an asynchronous process with a local buffer, +instead of calling an external client editor to run within emacs. + +Arguments: +P4-THIS-COMMAND is the command that called this internal function. + +P4-REGEXP is the optional regular expression to search for to set the cursor +on. + +P4-THIS-BUFFER is the optional buffer to create. (Default is *P4 <command>*). + +P4-OUT-COMMAND is the optional command that will be used as the command to +be called when `p4-async-call-process' is called. + +P4-IN-ARGS is the optional argument passed that will be used as the list of +arguments to the P4-THIS-COMMAND. + +P4-OUT-ARGS is the optional argument passed that will be used as the list of +arguments to P4-OUT-COMMAND." + (if p4-this-buffer + (set-buffer (get-buffer-create p4-this-buffer)) + (set-buffer (get-buffer-create (concat "*P4 " p4-this-command "*")))) + (setq p4-current-command p4-this-command) + (if (zerop (apply 'call-process-region (point-min) (point-max) + (p4-check-p4-executable) t t nil + p4-current-command "-o" + p4-in-args)) + (progn + (goto-char (point-min)) + (insert (concat "# Created using " (p4-emacs-version) ".\n" + "# Type C-c C-c to submit changes and exit buffer.\n" + "# Type C-x k to kill current changes.\n" + "#\n")) + (if p4-regexp (re-search-forward p4-regexp)) + (indented-text-mode) + (setq p4-async-minor-mode t) + (setq fill-column 79) + (p4-push-window-config) + (switch-to-buffer-other-window (current-buffer)) + (if p4-out-command + (setq p4-current-command p4-out-command)) + (setq p4-current-args p4-out-args) + (setq buffer-offer-save t) + + (define-key p4-async-minor-map "\C-c\C-c" 'p4-async-call-process) + (run-hooks 'p4-async-command-hook) + (set-buffer-modified-p nil) + (message "C-c C-c to finish editing and exit buffer.")) + (error "%s %s -o failed to complete successfully." + (p4-check-p4-executable) p4-current-command))) + +(defun p4-async-call-process () + "Internal function called by `p4-async-process-command' to process the +buffer after editing is done using the minor mode key mapped to `C-c C-c'." + (interactive) + (message "p4 %s ..." p4-current-command) + (let ((max (point-max)) msg + (current-command p4-current-command) + (current-args p4-current-args)) + (goto-char max) + (if (zerop (apply 'call-process-region (point-min) + max (p4-check-p4-executable) + nil '(t t) nil + current-command "-i" + current-args)) + (progn + (goto-char max) + (setq msg (buffer-substring max (point-max))) + (delete-region max (point-max)) + (save-excursion + (set-buffer (get-buffer-create p4-output-buffer-name)) + (delete-region (point-min) (point-max)) + (insert msg)) + (kill-buffer nil) + (display-buffer p4-output-buffer-name) + (p4-partial-cache-cleanup current-command) + (message "p4 %s done." current-command) + (if (equal current-command "submit") + (progn + (p4-refresh-files-in-buffers) + (p4-check-mode-all-buffers) + (if p4-notify + (p4-notify p4-notify-list))))) + (error "%s %s -i failed to complete successfully." + (p4-check-p4-executable) + current-command)))) + +(defun p4-cmd-line-flags (args) + (memq t (mapcar (lambda (x) (not (not (string-match "^-" x)))) + args))) + +;; The p4 change command +(defp4cmd p4-change () + "change" "To edit the change specification, type \\[p4-change].\n" + (interactive) + (let (args + (change-buf-name "*P4 New Change*")) + (if (buffer-live-p (get-buffer change-buf-name)) + (switch-to-buffer-other-window (get-buffer change-buf-name)) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 change: " nil)))) + (if (p4-cmd-line-flags args) + (p4-noinput-buffer-action "change" nil t args) + (p4-async-process-command "change" "Description:\n\t" + change-buf-name nil args))))) + +;; The p4 client command +(defp4cmd p4-client () + "client" "To edit a client specification, type \\[p4-client].\n" + (interactive) + (let (args + (client-buf-name "*P4 client*")) + (if (buffer-live-p (get-buffer client-buf-name)) + (switch-to-buffer-other-window (get-buffer client-buf-name)) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 client: " nil "client")))) + (if (p4-cmd-line-flags args) + (p4-noinput-buffer-action "client" nil t args) + (p4-async-process-command "client" "\\(Description\\|View\\):\n\t" + client-buf-name nil args))))) + +(defp4cmd p4-clients () + "clients" "To list all clients, type \\[p4-clients].\n" + (interactive) + (p4-noinput-buffer-action "clients" nil t nil) + (p4-make-basic-buffer "*P4 clients*") + (p4-regexp-create-links "*P4 clients*" "^Client \\([^ ]+\\).*\n" 'client)) + +(defp4cmd p4-branch (args) + "branch" "Edit a P4-BRANCH specification using \\[p4-branch]." + (interactive (list + (p4-make-list-from-string + (p4-read-arg-string "p4 branch: " nil "branch")))) + (if (or (null args) (equal args (list ""))) + (error "Branch must be specified!") + (if (p4-cmd-line-flags args) + (p4-noinput-buffer-action "branch" nil t args) + (p4-async-process-command "branch" "Description:\n\t" + (concat "*P4 Branch: " + (car (reverse args)) "*") + "branch" args)))) + +(defp4cmd p4-branches () + "branches" "To list all branches, type \\[p4-branches].\n" + (interactive) + (p4-noinput-buffer-action "branches" nil t nil) + (p4-make-basic-buffer "*P4 branches*") + (p4-regexp-create-links "*P4 branches*" "^Branch \\([^ ]+\\).*\n" 'branch)) + +(defp4cmd p4-label (args) + "label" "Edit a P4-label specification using \\[p4-label].\n" + (interactive (list + (p4-make-list-from-string + (p4-read-arg-string "p4 label: " nil "label")))) + (if (or (null args) (equal args (list ""))) + (error "label must be specified!") + (if (p4-cmd-line-flags args) + (p4-noinput-buffer-action "label" nil t args) + (p4-async-process-command "label" "Description:\n\t" + (concat "*P4 label: " + (car (reverse args)) "*") + "label" args)))) + +(defp4cmd p4-labels () + "labels" "To display list of defined labels, type \\[p4-labels].\n" + (interactive) + (p4-noinput-buffer-action "labels" nil t nil) + (p4-make-basic-buffer "*P4 labels*") + (p4-regexp-create-links "*P4 labels*" "^Label \\([^ ]+\\).*\n" 'label)) + +;; The p4 labelsync command +(defp4cmd p4-labelsync () + "labelsync" + "To synchronize a label with the current client contents, type \\[p4-labelsync].\n" + (interactive) + (let ((args (p4-make-list-from-string + (p4-read-arg-string "p4 labelsync: ")))) + (p4-noinput-buffer-action "labelsync" nil t args)) + (p4-make-depot-list-buffer "*P4 labelsync*")) + +(defun p4-filter-out (pred lst) + (let (res) + (while lst + (if (not (funcall pred (car lst))) + (setq res (cons (car lst) res))) + (setq lst (cdr lst))) + (reverse res))) + +;; The p4 submit command +(defp4cmd p4-submit (&optional arg) + "submit" "To submit a pending change to the depot, type \\[p4-submit].\n" + (interactive "P") + (let (args + (submit-buf-name "*P4 Submit*") + (change-list (if (integerp arg) arg))) + (if (buffer-live-p (get-buffer submit-buf-name)) + (switch-to-buffer-other-window (get-buffer submit-buf-name)) + (if change-list + (setq args (list "-c" (int-to-string change-list))) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 submit: " nil))))) + (setq args (p4-filter-out (lambda (x) (string= x "-c")) args)) + (p4-save-opened-files) + (if (or (not (and p4-check-empty-diffs (p4-empty-diff-p))) + (progn + (ding t) + (yes-or-no-p + "File with empty diff opened for edit. Submit anyway? "))) + (p4-async-process-command "change" "Description:\n\t" + submit-buf-name "submit" args))))) + +;; The p4 user command +(defp4cmd p4-user () + "user" "To create or edit a user specification, type \\[p4-user].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 user: " nil "user")))) + (if (p4-cmd-line-flags args) + (p4-noinput-buffer-action "user" nil t args) + (p4-async-process-command "user" nil nil nil args)))) + +;; The p4 job command +(defp4cmd p4-job () + "job" "To create or edit a job, type \\[p4-job].\n" + (interactive) + (let (args) + (if current-prefix-arg + (setq args (p4-make-list-from-string + (p4-read-arg-string "p4 job: " nil "job")))) + (if (p4-cmd-line-flags args) + (p4-noinput-buffer-action "job" nil t args) + (p4-async-process-command "job" "Description:\n\t" nil nil args)))) + +;; The p4 jobspec command +(defp4cmd p4-jobspec () + "jobspec" "To edit the job template, type \\[p4-jobspec].\n" + (interactive) + (p4-async-process-command "jobspec")) + +;; A function to set the current P4 client name +(defun p4-set-client-name (p4-new-client-name) + "To set the current value of P4CLIENT, type \\[p4-set-client-name]. + +This will change the current client from the previous client to the new +given value. + +Setting this value to nil would disable P4 Version Checking. + +`p4-set-client-name' will complete any client names set using the function +`p4-set-my-clients'. The strictness of completion will depend on the +variable `p4-strict-complete' (default is t). + +Argument P4-NEW-CLIENT-NAME The new client to set to. The default value is +the current client." + (interactive (list + (completing-read "Change Client to: " + (if p4-my-clients + p4-my-clients + 'p4-clients-completion) + nil p4-strict-complete (p4-current-client)) + )) + (if (or (null p4-new-client-name) (equal p4-new-client-name "nil")) + (progn + (setenv "P4CLIENT" nil) + (if (not (getenv "P4CONFIG")) + (message + "P4 Version check disabled. Set a valid client name to enable." + ))) + (setenv "P4CLIENT" p4-new-client-name) + (message "P4CLIENT changed to %s" p4-new-client-name) + (run-hooks 'p4-set-client-hooks))) + +(defun p4-get-client-config () + "To get the current value of the environment variable P4CONFIG, +type \\[p4-get-client-config]. + +This will be the current configuration that is in use for access through +Emacs P4." + + (interactive) + (message "P4CONFIG is %s" (getenv "P4CONFIG"))) + +(defun p4-set-client-config (p4config) + "To set the P4CONFIG variable, for use with the current versions of the p4 +client. + +P4CONFIG is a more flexible mechanism wherein p4 will find the current +client automatically by checking the config file found at the root of a +directory \(recursing all the way to the top\). + +In this scenario, a P4CLIENT variable need not be explicitly set. +" + (interactive "sP4 Config: ") + (if (or (null p4config) (equal p4config "")) + (message "P4CONFIG not changed.") + (setenv "P4CONFIG" p4config) + (message "P4CONFIG changed to %s" p4config))) + +(defun p4-set-my-clients (client-list) + "To set the client completion list used by `p4-set-client-name', use +this function in your .emacs (or any lisp interaction buffer). + +This will change the current client list from the previous list to the new +given value. + +Setting this value to nil would disable client completion by +`p4-set-client-name'. + +The strictness of completion will depend on the variable +`p4-strict-complete' (default is t). + +Argument CLIENT-LIST is the 'list' of clients. + +To set your clients using your .emacs, use the following: + +\(load-library \"p4\"\) +\(p4-set-my-clients \'(client1 client2 client3)\)" + (setq p4-my-clients nil) + (let (p4-tmp-client-var) + (while client-list + (setq p4-tmp-client-var (format "%s" (car client-list))) + (setq client-list (cdr client-list)) + (setq p4-my-clients (append p4-my-clients + (list (list p4-tmp-client-var))))))) + +;; A function to get the current P4PORT +(defun p4-get-p4-port () + "To get the current value of the environment variable P4PORT, type \ +\\[p4-get-p4-port]. + +This will be the current server/port that is in use for access through Emacs +P4." + (interactive) + (message "P4PORT is %s" (getenv "P4PORT"))) + +;; A function to set the current P4PORT +(defun p4-set-p4-port (p4-new-p4-port) + "To set the current value of P4PORT, type \\[p4-set-p4-port]. + +This will change the current server from the previous server to the new +given value. + +Argument P4-NEW-P4-PORT The new server:port to set to. The default value is +the current value of P4PORT." + (interactive (list (let + ((symbol (read-string "Change server:port to: " + (getenv "P4PORT")))) + (if (equal symbol "") + (getenv "P4PORT") + symbol)))) + (if (or (null p4-new-p4-port) (equal p4-new-p4-port "nil")) + (progn + (setenv "P4PORT" nil) + (if (not (getenv "P4CONFIG")) + (message + "P4 Version check disabled. Set a valid server:port to enable."))) + (setenv "P4PORT" p4-new-p4-port) + (message "P4PORT changed to %s" p4-new-p4-port))) + +;; The find-file hook for p4. +(defun p4-find-file-hook () + "To check while loading the file, if it is a P4 version controlled file." + (if (or (getenv "P4CONFIG") (getenv "P4CLIENT")) + (p4-detect-p4))) + +(defun p4-refresh-refresh-list (buffile bufname) + "Refresh the list of files to be refreshed." + (setq p4-all-buffer-files (delete (list buffile bufname) + p4-all-buffer-files)) + (if (not p4-all-buffer-files) + (progn + (if (and p4-running-emacs (timerp p4-file-refresh-timer)) + (cancel-timer p4-file-refresh-timer)) + (if (and p4-running-xemacs p4-file-refresh-timer) + (disable-timeout p4-file-refresh-timer)) + (setq p4-file-refresh-timer nil)))) + +;; Set keymap. We use the C-x p Keymap for all perforce commands +(defvar p4-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'p4-add) + (define-key map "b" 'p4-bug-report) + (define-key map "B" 'p4-branch) + (define-key map "c" 'p4-client) + (define-key map "C" 'p4-changes) + (define-key map "d" 'p4-diff2) + (define-key map "D" 'p4-describe) + (define-key map "e" 'p4-edit) + (define-key map "E" 'p4-reopen) + (define-key map "\C-f" 'p4-depot-find-file) + (define-key map "f" 'p4-filelog) + (define-key map "F" 'p4-files) + (define-key map "g" 'p4-get-client-name) + (define-key map "G" 'p4-get) + (define-key map "h" 'p4-help) + (define-key map "H" 'p4-have) + (define-key map "i" 'p4-info) + (define-key map "I" 'p4-integ) + (define-key map "j" 'p4-job) + (define-key map "J" 'p4-jobs) + (define-key map "l" 'p4-label) + (define-key map "L" 'p4-labels) + (define-key map "\C-l" 'p4-labelsync) + (define-key map "m" 'p4-rename) + (define-key map "n" 'p4-notify) + (define-key map "o" 'p4-opened) + (define-key map "p" 'p4-print) + (define-key map "P" 'p4-set-p4-port) + (define-key map "q" 'p4-pop-window-config) + (define-key map "r" 'p4-revert) + (define-key map "R" 'p4-refresh) + (define-key map "\C-r" 'p4-resolve) + (define-key map "s" 'p4-set-client-name) + (define-key map "S" 'p4-submit) + (define-key map "t" 'p4-toggle-vc-mode) + (define-key map "u" 'p4-user) + (define-key map "U" 'p4-users) + (define-key map "v" 'p4-emacs-version) + (define-key map "V" 'p4-blame) + (define-key map "w" 'p4-where) + (define-key map "x" 'p4-delete) + (define-key map "X" 'p4-fix) + (define-key map "=" 'p4-diff) + (define-key map "-" 'p4-ediff) + (define-key map "?" 'p4-describe-bindings) + map) + "The Prefix for P4 Library Commands.") + +(if (not (keymapp (lookup-key global-map "\C-xp"))) + (define-key global-map "\C-xp" p4-prefix-map)) + +;; For users interested in notifying a change, a notification list can be +;; set up using this function. +(defun p4-set-notify-list (p4-new-notify-list &optional p4-supress-stat) + "To set the current value of P4NOTIFY, type \\[p4-set-notify-list]. + +This will change the current notify list from the existing list to the new +given value. + +An empty string will disable notification. + +Argument P4-NEW-NOTIFY-LIST is new value of the notification list. +Optional argument P4-SUPRESS-STAT when t will suppress display of the status +message. " + + (interactive (list (let + ((symbol (read-string + "Change Notification List to: " + p4-notify-list))) + (if (equal symbol "") + nil + symbol)))) + (let ((p4-old-notify-list p4-notify-list)) + (setenv "P4NOTIFY" p4-new-notify-list) + (setq p4-notify-list p4-new-notify-list) + (setq p4-notify (not (null p4-new-notify-list))) + (if (not p4-supress-stat) + (message "Notification list changed from '%s' to '%s'" + p4-old-notify-list p4-notify-list)))) + +;; To get the current notification list. +(defun p4-get-notify-list () + "To get the current value of the environment variable P4NOTIFY, +type \\[p4-get-notify-list]. + + This will be the current notification list that is in use for mailing + change notifications through Emacs P4." + + (interactive) + (message "P4NOTIFY is %s" p4-notify-list)) + +(defun p4-notify (users) + "To notify a list of users of a change submission manually, type +\\[p4-notify]. + +To do auto-notification, set the notification list with `p4-set-notify-list' +and on each submission, the users in the list will be notified of the +change. + +Since this uses the sendmail program, it is mandatory to set the correct +path to the sendmail program in the variable `p4-sendmail-program'. + +Also, it is mandatory to set the user's email address in the variable +`p4-user-email'. + +Argument USERS The users to notify to. The default value is the notification +list." + (interactive (list (let + ((symbol (read-string "Notify whom? " + p4-notify-list))) + (if (equal symbol "") + nil + symbol)))) + (p4-set-notify-list users t) + (if (and p4-sendmail-program p4-user-email) + (p4-do-notify) + (message "Please set p4-sendmail-program and p4-user-email variables."))) + +(defun p4-do-notify () + "This is the internal notification function called by `p4-notify'." + (save-excursion + (if (and p4-notify-list (not (equal p4-notify-list ""))) + (save-excursion + (set-buffer (get-buffer-create p4-output-buffer-name)) + (goto-char (point-min)) + (if (re-search-forward "[0-9]+.*submitted" (point-max) t) + (let (p4-matched-change) + (setq p4-matched-change (substring (match-string 0) 0 -10)) + (set-buffer (get-buffer-create "*P4 Notify*")) + (delete-region (point-min) (point-max)) + (call-process-region (point-min) (point-max) + (p4-check-p4-executable) + t t nil "describe" "-s" + p4-matched-change) + (switch-to-buffer "*P4 Notify*") + (goto-char (point-min)) + (let (p4-chg-desc) + (if (re-search-forward "^Change.*$" (point-max) t) + (setq p4-chg-desc (match-string 0)) + (setq p4-chg-desc (concat + "Notification of Change " + p4-matched-change))) + (goto-char (point-min)) + (insert + "From: " p4-user-email "\n" + "To: P4 Notification Recipients:;\n" + "Subject: " p4-chg-desc "\n") + (call-process-region (point-min) (point-max) + p4-sendmail-program t t nil + "-odi" "-oi" p4-notify-list) + + (kill-buffer nil))) + (save-excursion + (set-buffer (get-buffer-create p4-output-buffer-name)) + (goto-char (point-max)) + (insert "\np4-do-notify: No Change Submissions found.")))) + (save-excursion + (set-buffer (get-buffer-create p4-output-buffer-name)) + (goto-char (point-max)) + (insert "\np4-do-notify: Notification list not set."))))) + +;; Function to return the current version. +(defun p4-emacs-version () + "Return the current Emacs-P4 Integration version." + (interactive) + (message (concat (cond (p4-running-xemacs "X")) "Emacs-P4 Integration v%s") + p4-emacs-version)) + +(defun p4-find-p4-config-file () + (let ((p4config (getenv "P4CONFIG")) + (p4-cfg-dir (cond ((p4-buffer-file-name) + (file-name-directory + (file-truename (p4-buffer-file-name)))) + (t (file-truename default-directory))))) + (if (not p4config) + nil + (let (found at-root) + (while (not (or found at-root)) + (let ((parent-dir (file-name-directory + (directory-file-name + p4-cfg-dir)))) + (if (file-exists-p (concat p4-cfg-dir p4config)) + (setq found (concat p4-cfg-dir p4config))) + (setq at-root (string-equal parent-dir p4-cfg-dir)) + (setq p4-cfg-dir parent-dir))) + found)))) + +(defun p4-detect-p4 () + (if (or (not p4-use-p4config-exclusively) + (p4-find-p4-config-file)) + (p4-check-mode))) + +(defun p4-get-add-branch-files (&optional name-list) + (let ((output-buffer (p4-depot-output "opened" name-list)) + files depot-map) + (save-excursion + (set-buffer output-buffer) + (goto-char (point-min)) + (while (re-search-forward "^\\(//[^/@#]+/[^#\n]*\\)#[0-9]+ - add " nil t) + (setq files (cons (cons (match-string 1) "Add") + files))) + (goto-char (point-min)) + (while (re-search-forward "^\\(//[^/@#]+/[^#\n]*\\)#[0-9]+ - branch " nil t) + (setq files (cons (cons (match-string 1) "Branch") + files)))) + (kill-buffer output-buffer) + (setq depot-map (p4-map-depot-files (mapcar 'car files))) + (mapcar (lambda (x) (cons (cdr (assoc (car x) depot-map)) + (cdr x))) files))) + +(defun p4-get-have-files (file-list) + (let ((output-buffer (p4-depot-output "have" file-list)) + line files depot-map elt) + (while (setq line (p4-read-depot-output output-buffer)) + (if (string-match "^\\(//[^/@#]+/[^#\n]*\\)#\\([0-9]+\\) - " line) + (setq files (cons (cons (match-string 1 line) + (match-string 2 line)) + files)))) + (kill-buffer output-buffer) + (setq depot-map (p4-map-depot-files (mapcar 'car files))) + (setq files (mapcar (lambda (x) (cons (cdr (assoc (car x) depot-map)) + (cdr x))) files)) + (while file-list + (setq elt (car file-list)) + (setq file-list (cdr file-list)) + (if (not (assoc elt files)) + (setq files (cons (cons elt nil) files)))) + files)) + +;; A function to check if the file being opened is version controlled by p4. +(defun p4-is-vc (&optional file-mode-cache filename) + "If a file is controlled by P4 then return version else return nil." + (if (not filename) + (setq filename (p4-buffer-file-name))) + (let (version done) + (let ((el (assoc filename file-mode-cache))) + (setq done el) + (setq version (cdr el))) + (if (and (not done) filename) + (let ((output-buffer (p4-depot-output "have" (list filename))) + line) + (setq line (p4-read-depot-output output-buffer)) + (kill-buffer output-buffer) + (if (string-match "^//[^/@#]+/[^#\n]*#\\([0-9]+\\) - " line) + (setq version (match-string 1 line))) + (setq done version))) + (if (and (not done) (not file-mode-cache)) + (progn + (setq file-mode-cache + (p4-get-add-branch-files (and filename (list filename)))) + (setq version (cdr (assoc filename file-mode-cache))))) + version)) + +(defun p4-check-mode (&optional file-mode-cache) + "Check to see whether we should export the menu map to this buffer. + +Turning on P4 mode calls the hooks in the variable `p4-mode-hook' with +no args." + (setq p4-mode nil) + (if p4-do-find-file + (progn + (setq p4-vc-check (p4-is-vc file-mode-cache)) + (if p4-vc-check + (progn + (p4-menu-add) + (setq p4-mode (concat " P4:" p4-vc-check)))) + (p4-force-mode-line-update) + (let ((buffile (p4-buffer-file-name)) + (bufname (buffer-name))) + (if (and p4-vc-check (not (member (list buffile bufname) + p4-all-buffer-files))) + (add-to-list 'p4-all-buffer-files (list buffile bufname)))) + (if (and (not p4-file-refresh-timer) (not (= p4-file-refresh-timer-time 0))) + (setq p4-file-refresh-timer + (cond (p4-running-emacs + (run-at-time nil p4-file-refresh-timer-time + 'p4-refresh-files-in-buffers)) + (p4-running-xemacs + (add-timeout p4-file-refresh-timer-time + 'p4-refresh-files-in-buffers nil + p4-file-refresh-timer-time))))) + ;; run hooks + (and p4-vc-check (run-hooks 'p4-mode-hook)) + p4-vc-check))) + +(defun p4-refresh-files-in-buffers (&optional arg) + "Check to see if all the files that are under P4 version control are +actually up-to-date, if in buffers, or need refreshing." + (interactive) + (let ((p4-all-my-files p4-all-buffer-files) buffile bufname thiselt) + (while p4-all-my-files + (setq thiselt (car p4-all-my-files)) + (setq p4-all-my-files (cdr p4-all-my-files)) + (setq buffile (car thiselt)) + (setq bufname (cadr thiselt)) + (if (buffer-live-p (get-buffer bufname)) + (save-excursion + (let ((buf (get-buffer bufname))) + (set-buffer buf) + (if p4-auto-refresh + (if (not (buffer-modified-p buf)) + (if (not (verify-visited-file-modtime buf)) + (if (file-readable-p buffile) + (revert-buffer t t) + (p4-check-mode)))) + (if (file-readable-p buffile) + (find-file-noselect buffile t) + (p4-check-mode))) + (setq buffer-read-only (not (file-writable-p + (p4-buffer-file-name)))))) + (p4-refresh-refresh-list buffile bufname))))) + +(defun p4-check-mode-all-buffers () + "Call p4-check-mode for all buffers under P4 version control" + (let ((p4-all-my-files p4-all-buffer-files) buffile bufname thiselt + file-mode-cache) + (if (and p4-all-my-files p4-do-find-file) + (setq file-mode-cache + (append (p4-get-add-branch-files) + (p4-get-have-files (mapcar 'car p4-all-my-files))))) + (while p4-all-my-files + (setq thiselt (car p4-all-my-files)) + (setq p4-all-my-files (cdr p4-all-my-files)) + (setq buffile (car thiselt)) + (setq bufname (cadr thiselt)) + (if (buffer-live-p (get-buffer bufname)) + (save-excursion + (set-buffer (get-buffer bufname)) + (p4-check-mode file-mode-cache)) + (p4-refresh-refresh-list buffile bufname))))) + +;; Force mode line updation for different Emacs versions +(defun p4-force-mode-line-update () + "To Force the mode line update for different flavors of Emacs." + (cond (p4-running-xemacs + (redraw-modeline)) + (p4-running-emacs + (force-mode-line-update)))) + +;; In case, the P4 server is not available, or when operating off-line, the +;; p4-find-file-hook becomes a pain... this functions toggles the use of the +;; hook when opening files. + +(defun p4-toggle-vc-mode () + "In case, the P4 server is not available, or when working off-line, toggle +the VC check on/off when opening files." + (interactive) + (setq p4-do-find-file (not p4-do-find-file)) + (message (concat "P4 mode check " (if p4-do-find-file + "enabled." + "disabled.")))) + +;; Wrap C-x C-q to allow p4-edit/revert and also to ensure that +;; we don't stomp on vc-toggle-read-only. + +(defun p4-toggle-read-only (&optional arg) + "If p4-mode is non-nil, \\[p4-toggle-read-only] toggles between `p4-edit' +and `p4-revert'. If ARG is non-nil, p4-offline-mode will be enabled for this +buffer before the toggling takes place. In p4-offline-mode, toggle between +making the file writable and write protected." + (interactive "P") + (if (and arg p4-mode) + (setq p4-mode nil + p4-offline-mode t)) + (cond + (p4-mode + (if buffer-read-only + (p4-edit p4-verbose) + (p4-revert p4-verbose))) + (p4-offline-mode + (toggle-read-only) + (if buffer-file-name + (let ((mode (file-modes buffer-file-name))) + (if buffer-read-only + (setq mode (logand mode (lognot 128))) + (setq mode (logior mode 128))) + (set-file-modes buffer-file-name mode)))))) + +(defun p4-browse-web-page () + "Browse the p4.el web page." + (interactive) + (require 'browse-url) + (browse-url p4-web-page)) + +(defun p4-bug-report () + (interactive) + (if (string-match " 19\\." (emacs-version)) + ;; unfortunately GNU Emacs 19.x doesn't have compose-mail + (mail nil p4-emacs-maintainer (concat "BUG REPORT: " + (p4-emacs-version))) + (compose-mail p4-emacs-maintainer (concat "BUG REPORT: " + (p4-emacs-version)))) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) + ;; Insert warnings for novice users. + (insert + "This bug report will be sent to the P4-Emacs Integration Maintainer,\n" + p4-emacs-maintainer "\n\n") + (insert (concat (emacs-version) "\n\n")) + (insert "A brief description of the problem and how to reproduce it:\n") + (save-excursion + (let ((message-buf (get-buffer + (cond (p4-running-xemacs " *Message-Log*") + (p4-running-emacs "*Messages*"))))) + (if message-buf + (let (beg-pos + (end-pos (point-max))) + (save-excursion + (set-buffer message-buf) + (goto-char end-pos) + (forward-line -10) + (setq beg-pos (point))) + (insert "\n\nRecent messages:\n") + (insert-buffer-substring message-buf beg-pos end-pos)))))) + +(defun p4-describe-bindings () + "A function to list the key bindings for the p4 prefix map" + (interactive) + (save-excursion + (p4-push-window-config) + (let ((map (make-sparse-keymap)) + (p4-bindings-buffer "*P4 key bindings*")) + (get-buffer-create p4-bindings-buffer) + (cond + (p4-running-xemacs + (set-buffer p4-bindings-buffer) + (delete-region (point-min) (point-max)) + (insert "Key Bindings for P4 Mode\n------------------------\n") + (describe-bindings-internal p4-prefix-map)) + (p4-running-emacs + (kill-buffer p4-bindings-buffer) + (describe-bindings "\C-xp") + (set-buffer "*Help*") + (rename-buffer p4-bindings-buffer))) + (define-key map "q" 'p4-quit-current-buffer) + (use-local-map map) + (display-buffer p4-bindings-buffer)))) + +;; Break up a string into a list of words +;; (p4-make-list-from-string "ab c de f") -> ("ab" "c" "de" "f") +(defun p4-make-list-from-string (str) + (let (lst) + (while (or (string-match "^ *\"\\([^\"]*\\)\"" str) + (string-match "^ *\'\\([^\']*\\)\'" str) + (string-match "^ *\\([^ ]+\\)" str)) + (setq lst (append lst (list (match-string 1 str)))) + (setq str (substring str (match-end 0)))) + lst)) + +(defun p4-list-to-string (lst) + (mapconcat (lambda (x) x) lst " ")) + +;; Return the file name associated with a buffer. If the real buffer file +;; name doesn't exist, try special filename tags set in some of the p4 +;; buffers. +(defun p4-buffer-file-name-2 () + (cond ((p4-buffer-file-name)) + ((get-char-property (point) 'link-client-name)) + ((get-char-property (point) 'link-depot-name)) + ((get-char-property (point) 'block-client-name)) + ((get-char-property (point) 'block-depot-name)) + ((if (and (fboundp 'dired-get-filename) + (dired-get-filename nil t)) + (p4-follow-link-name (dired-get-filename nil t)))))) + +(defun p4-buffer-file-name () + (cond (buffer-file-name + (p4-follow-link-name buffer-file-name)) + (t nil))) + +(defun p4-follow-link-name (name) + (if p4-follow-symlinks + (file-truename name) + name)) + +(defvar p4-depot-filespec-history nil + "History for p4-depot filespecs.") + +(defvar p4-depot-completion-cache nil + "Cache for `p4-depot-completion'. +It is a list of lists whose car is a filespec and +cdr is the list of anwers") + +(defvar p4-branches-history nil + "History for p4 clients.") + +(defvar p4-branches-completion-cache nil + "Cache for `p4-depot-completion'. +It is a list of lists whose car is a client and +cdr is the list of answers??") + +(defvar p4-clients-history nil + "History for p4 clients.") + +(defvar p4-clients-completion-cache nil + "Cache for `p4-depot-completion'. +It is a list of lists whose car is a client and +cdr is the list of answers??") + +(defvar p4-jobs-completion-cache nil + "Cache for `p4-depot-completion'. +It is a list of lists whose car is a client and +cdr is the list of answers??") + +(defvar p4-labels-history nil + "History for p4 clients.") + +(defvar p4-labels-completion-cache nil + "Cache for `p4-depot-completion'. +It is a list of lists whose car is a client and +cdr is the list of answers??") + +(defvar p4-users-completion-cache nil + "Cache for `p4-depot-completion'. +It is a list of lists whose car is a client and +cdr is the list of answers??") + +(defvar p4-arg-string-history nil + "History for p4 command arguments") + +(defun p4-depot-completion-search (filespec cmd) + "Look into `p4-depot-completion-cache' for filespec. +Filespec is the candidate for completion, so the +exact file specification is \"filespec*\". + +If found in cache, return a list whose car is FILESPEC and cdr is the list +of matches. +If not found in cache, return nil. +So the 'no match' answer is different from 'not in cache'." + (let ((l (cond + ((equal cmd "branches") p4-branches-completion-cache) + ((equal cmd "clients") p4-clients-completion-cache) + ((equal cmd "dirs") p4-depot-completion-cache) + ((equal cmd "jobs") p4-jobs-completion-cache) + ((equal cmd "labels") p4-labels-completion-cache) + ((equal cmd "users") p4-users-completion-cache))) + dir list) + + (if (and p4-cleanup-cache (not p4-timer)) + (setq p4-timer (cond (p4-running-emacs + (run-at-time p4-cleanup-time nil + 'p4-cache-cleanup)) + (p4-running-xemacs + (add-timeout p4-cleanup-time 'p4-cache-cleanup + nil nil))))) + (while l + (if (string-match (concat "^" (car (car l)) "[^/]*$") filespec) + (progn + ;; filespec is included in cache + (if (string= (car (car l)) filespec) + (setq list (cdr (car l))) + (setq dir (cdr (car l))) + (while dir + (if (string-match (concat "^" filespec) (car dir)) + (setq list (cons (car dir) list))) + (setq dir (cdr dir)))) + (setq l nil + list (cons filespec list)))) + (setq l (cdr l))) + list)) + +(defun p4-cache-cleanup (&optional arg) + "Cleanup all the completion caches." + (message "Cleaning up the p4 caches ...") + (setq p4-branches-completion-cache nil) + (setq p4-clients-completion-cache nil) + (setq p4-depot-completion-cache nil) + (setq p4-jobs-completion-cache nil) + (setq p4-labels-completion-cache nil) + (setq p4-users-completion-cache nil) + (if (and p4-running-emacs (timerp p4-timer)) (cancel-timer p4-timer)) + (if (and p4-running-xemacs p4-timer) (disable-timeout p4-timer)) + (setq p4-timer nil) + (message "Cleaning up the p4 caches ... done.")) + +(defun p4-partial-cache-cleanup (type) + "Cleanup a specific completion cache." + (cond ((string= type "branch") + (setq p4-branches-completion-cache nil)) + ((string= type "client") + (setq p4-clients-completion-cache nil)) + ((or (string= type "submit") (string= type "change")) + (setq p4-depot-completion-cache nil)) + ((string= type "job") + (setq p4-jobs-completion-cache nil)) + ((string= type "label") + (setq p4-labels-completion-cache nil)) + ((string= type "user") + (setq p4-users-completion-cache nil)))) + +(defun p4-read-depot-output (buffer &optional regexp) + "Reads first line of BUFFER and returns it. +Read lines are deleted from buffer. + +If optional REGEXP is passed in, return the substring of the first line that +matched the REGEXP." + + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (forward-line) + + (let ((line (buffer-substring (point-min) (point)))) + (if (string= line "") + nil + (delete-region (point-min) (point)) + (if (and regexp (string-match regexp line)) + (setq line (substring line (match-beginning 1) (match-end 1)))) + + ;; remove trailing newline + (if (equal (substring line (1- (length line)) (length line)) "\n") + (substring line 0 (1- (length line))) + line))))) + +(defun p4-completion-helper (filespec cmd var regexp) + (let (output-buffer line list) + (message "Making %s completion list..." cmd) + (setq output-buffer (p4-depot-output cmd)) + (while (setq line (p4-read-depot-output + output-buffer regexp)) + (if line + (setq list (cons line list)))) + (kill-buffer output-buffer) + (set var + (cons (cons filespec list) (eval var))) + list)) + +(defun p4-depot-completion-build (filespec cmd) + "Ask Perforce for a list of files and directories beginning with FILESPEC." + (let (output-buffer line list) + (cond + ((equal cmd "branches") + (setq list (p4-completion-helper + filespec cmd 'p4-branches-completion-cache + "^Branch \\([^ \n]*\\) [0-9][0-9][0-9][0-9]/.*$"))) + ((equal cmd "clients") + (setq list (p4-completion-helper + filespec cmd 'p4-clients-completion-cache + "^Client \\([^ \n]*\\) [0-9][0-9][0-9][0-9]/.*$"))) + + ((equal cmd "dirs") + (message "Making p4 completion list...") + (setq output-buffer (p4-depot-output cmd + (list (concat filespec "*")))) + (while (setq line (p4-read-depot-output output-buffer)) + (if (not (string-match "no such file" line)) + (setq list (cons (concat line "/") list)))) + (kill-buffer output-buffer) + (setq output-buffer (p4-depot-output "files" + (list (concat filespec "*")))) + (while (setq line (p4-read-depot-output output-buffer)) + (if (string-match "^\\(.+\\)#[0-9]+ - " line) + (setq list (cons (match-string 1 line) list)))) + (kill-buffer output-buffer) + (setq p4-depot-completion-cache + (cons (cons filespec list) p4-depot-completion-cache))) + + ((equal cmd "jobs") + (setq list (p4-completion-helper + filespec cmd 'p4-jobs-completion-cache + "\\([^ \n]*\\) on [0-9][0-9][0-9][0-9]/.*$"))) + ((equal cmd "labels") + (setq list (p4-completion-helper + filespec cmd 'p4-labels-completion-cache + "^Label \\([^ \n]*\\) [0-9][0-9][0-9][0-9]/.*$"))) + ((equal cmd "users") + (setq list (p4-completion-helper + filespec cmd 'p4-users-completion-cache + "^\\([^ ]+\\).*$")))) + (message nil) + (cons filespec list))) + +(defun p4-completion-builder (type) + `(lambda (string predicate action) + ,(concat "Completion function for Perforce " type ". + +Using the mouse in completion buffer on a client will select it +and exit, unlike standard selection. This is because +`choose-completion-string' (in simple.el) has a special code for +file name selection.") + (let (list) + ,(if (string= type "dirs") + ;; when testing for an exact match, remove trailing / + `(if (and (eq action 'lambda) + (eq (aref string (1- (length string))) ?/)) + (setq string (substring string 0 (1- (length string)))))) + + ;; First, look in cache + (setq list (p4-depot-completion-search string ,type)) + + ;; If not found in cache, build list. + (if (not list) + (setq list (p4-depot-completion-build string ,type))) + + (cond + ;; try completion + ((null action) + (try-completion string (mapcar 'list (cdr list)) predicate)) + ;; all completions + ((eq action t) + (let ((lst + (all-completions string (mapcar 'list (cdr list)) predicate))) + ,(if (string= type "dirs") + `(setq lst (mapcar (lambda (s) + (if (string-match ".*/\\(.+\\)" s) + (match-string 1 s) + s)) + lst))) + lst)) + ;; Test for an exact match + (t + (and (>= (length list) 2) + (member (car list) (cdr list)))))))) + +(defalias 'p4-branches-completion (p4-completion-builder "branches")) +(defalias 'p4-clients-completion (p4-completion-builder "clients")) +(defalias 'p4-depot-completion (p4-completion-builder "dirs")) +(defalias 'p4-jobs-completion (p4-completion-builder "jobs")) +(defalias 'p4-labels-completion (p4-completion-builder "labels")) +(defalias 'p4-users-completion (p4-completion-builder "users")) + + +(defun p4-read-arg-string (prompt &optional initial type) + (let ((minibuffer-local-completion-map + (copy-keymap minibuffer-local-completion-map))) + (define-key minibuffer-local-completion-map " " 'self-insert-command) + (completing-read prompt + (cond ((not type) + 'p4-arg-string-completion) + ((string= type "branch") + 'p4-branch-string-completion) + ((string= type "client") + 'p4-client-string-completion) + ((string= type "label") + 'p4-label-string-completion) + ((string= type "job") + 'p4-job-string-completion) + ((string= type "user") + 'p4-user-string-completion)) + nil nil + initial 'p4-arg-string-history))) + +(defun p4-arg-string-completion (string predicate action) + (let ((first-part "") completion) + (if (string-match "^\\(.* +\\)\\(.*\\)" string) + (progn + (setq first-part (match-string 1 string)) + (setq string (match-string 2 string)))) + (cond ((string-match "-b +$" first-part) + (setq completion (p4-branches-completion string predicate action))) + ((string-match "-t +$" first-part) + (setq completion (p4-list-completion + string (list "text " "xtext " "binary " + "xbinary " "symlink ") + predicate action))) + ((string-match "-j +$" first-part) + (setq completion (p4-jobs-completion string predicate action))) + ((string-match "-l +$" first-part) + (setq completion (p4-labels-completion string predicate action))) + ((string-match "\\(.*status=\\)\\(.*\\)" string) + (setq first-part (concat first-part (match-string 1 string))) + (setq string (match-string 2 string)) + (setq completion (p4-list-completion + string (list "open " "closed " "suspended ") + predicate action))) + ((or (string-match "\\(.*@.+,\\)\\(.*\\)" string) + (string-match "\\(.*@\\)\\(.*\\)" string)) + (setq first-part (concat first-part (match-string 1 string))) + (setq string (match-string 2 string)) + (setq completion (p4-labels-completion string predicate action))) + ((string-match "\\(.*#\\)\\(.*\\)" string) + (setq first-part (concat first-part (match-string 1 string))) + (setq string (match-string 2 string)) + (setq completion (p4-list-completion + string (list "none" "head" "have") + predicate action))) + ((string-match "^//" string) + (setq completion (p4-depot-completion string predicate action))) + ((string-match "\\(^-\\)\\(.*\\)" string) + (setq first-part (concat first-part (match-string 1 string))) + (setq string (match-string 2 string)) + (setq completion (p4-list-completion + string (list "a " "af " "am " "as " "at " "ay " + "b " "c " "d " "dc " "dn " + "ds " "du " "e " "f " "i " "j " + "l " "m " "n " "q " "r " "s " "sa " + "sd " "se " "sr " "t " "v ") + predicate action))) + (t + (setq completion (p4-file-name-completion string + predicate action)))) + (cond ((null action) ;; try-completion + (if (stringp completion) + (concat first-part completion) + completion)) + ((eq action t) ;; all-completions + completion) + (t ;; exact match + completion)))) + +(defun p4-list-completion (string lst predicate action) + (let ((collection (mapcar 'list lst))) + (cond ((not action) + (try-completion string collection predicate)) + ((eq action t) + (all-completions string collection predicate)) + (t + (eq (try-completion string collection predicate) t))))) + +(defun p4-file-name-completion (string predicate action) + (if (string-match "//\\(.*\\)" string) + (setq string (concat "/" (match-string 1 string)))) + (setq string (substitute-in-file-name string)) + (setq string (p4-follow-link-name (expand-file-name string))) + (let ((dir-path "") completion) + (if (string-match "^\\(.*[/\\]\\)\\(.*\\)" string) + (progn + (setq dir-path (match-string 1 string)) + (setq string (match-string 2 string)))) + (cond ((not action) + (setq completion (file-name-completion string dir-path)) + (if (stringp completion) + (concat dir-path completion) + completion)) + ((eq action t) + (file-name-all-completions string dir-path)) + (t + (eq (file-name-completion string dir-path) t))))) + +(defun p4-string-completion-builder (completion-function) + `(lambda (string predicate action) + (let ((first-part "") completion) + (if (string-match "^\\(.* +\\)\\(.*\\)" string) + (progn + (setq first-part (match-string 1 string)) + (setq string (match-string 2 string)))) + (cond ((string-match "^-" string) + (setq completion nil)) + (t + (setq completion + (,completion-function string predicate action)))) + (cond ((null action);; try-completion + (if (stringp completion) + (concat first-part completion) + completion)) + ((eq action t);; all-completions + completion) + (t;; exact match + completion))))) + +(defalias 'p4-branch-string-completion (p4-string-completion-builder + 'p4-branches-completion)) + +(defalias 'p4-client-string-completion (p4-string-completion-builder + 'p4-clients-completion)) + +(defalias 'p4-job-string-completion (p4-string-completion-builder + 'p4-jobs-completion)) + +(defalias 'p4-label-string-completion (p4-string-completion-builder + 'p4-labels-completion)) + +(defalias 'p4-user-string-completion (p4-string-completion-builder + 'p4-users-completion)) + +(defun p4-depot-find-file (file) + (interactive (list (completing-read "Enter filespec: " + 'p4-depot-completion + nil nil + p4-default-depot-completion-prefix + 'p4-depot-filespec-history))) + (let ((lfile (cdar (p4-map-depot-files (list file))))) + (if lfile + (find-file lfile) + (if (get-file-buffer file) + (switch-to-buffer-other-window file) + (get-buffer-create file) + (set-buffer file) + (p4-noinput-buffer-action "print" nil t (list file)) + (p4-activate-print-buffer file t))))) + + +;; A function to get the current P4 client name +(defun p4-get-client-name () + "To get the current value of the environment variable P4CLIENT, +type \\[p4-get-client-name]. + +This will be the current client that is in use for access through +Emacs P4." + (interactive) + (let ((client (p4-current-client))) + (message "P4CLIENT [local: %s], [global: %s]" client (getenv "P4CLIENT")) + client)) + +(defun p4-get-config-info (file-name token) + (let ((output-buffer (generate-new-buffer p4-output-buffer-name)) + (data (getenv token))) + (save-excursion + (set-buffer output-buffer) + (goto-char (point-min)) + (insert-file-contents file-name) + (goto-char (point-min)) + (if (re-search-forward (concat "^" (regexp-quote token) "=\\(.*\\)") + nil t) + (setq data (match-string 1)))) + (kill-buffer output-buffer) + data)) + +(defun p4-current-client () + "Get the current local client, or the global client, if that." + (let ((p4-config-file (p4-find-p4-config-file)) + cur-client pmin) + (if (not p4-config-file) + (setq cur-client (getenv "P4CLIENT")) + (setq cur-client (p4-get-config-info p4-config-file "P4CLIENT"))) + (if (not cur-client) + (save-excursion + (get-buffer-create p4-output-buffer-name) + (set-buffer p4-output-buffer-name) + (goto-char (point-max)) + (setq pmin (point)) + (if (zerop (call-process + (p4-check-p4-executable) nil t nil "info")) + (progn + (goto-char pmin) + (if (re-search-forward "^Client name:[ \t]+\\(.*\\)$" nil t) + (setq cur-client (match-string 1))) + (delete-region pmin (point-max)))))) + cur-client)) + +(defun p4-current-server-port () + "Get the current local server:port address, or the global server:port, if +that." + (let ((p4-config-file (p4-find-p4-config-file))) + (if (not p4-config-file) + (getenv "P4PORT") + (p4-get-config-info p4-config-file "P4PORT")))) + +(defun p4-save-opened-files () + (get-buffer-create p4-output-buffer-name);; We do these two lines + (kill-buffer p4-output-buffer-name) ;; to ensure no duplicates + (let ((output-buffer (p4-depot-output "opened")) + opened) + (save-excursion + (set-buffer output-buffer) + (goto-char (point-min)) + (while (re-search-forward "^\\(.*\\)#[0-9]+ - " nil t) + (setq opened (cons (match-string 1) opened)))) + (kill-buffer output-buffer) + (setq opened (mapcar 'cdr (p4-map-depot-files opened))) + (save-window-excursion + (map-y-or-n-p + (function + (lambda (buffer) + (and (buffer-modified-p buffer) + (not (buffer-base-buffer buffer)) + (buffer-file-name buffer) + (member (buffer-file-name buffer) opened) + (format "Save file %s? " + (buffer-file-name buffer))))) + (function + (lambda (buffer) + (set-buffer buffer) + (save-buffer))) + (buffer-list) + '("buffer" "buffers" "save"))))) + +(defun p4-empty-diff-p () + "Return t if there exists a file opened for edit with an empty diff" + (let ((buffer (get-buffer-create "p4-edp-buf")) + opened empty-diff) + (p4-exec-p4 buffer (list "opened") t) + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (while (re-search-forward "^\\(.*\\)#[0-9]* - edit.*" nil t) + (setq opened (cons (match-string 1) opened)))) + (if opened + (progn + (p4-exec-p4 buffer (list "diff") t) + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (insert "====\n") + (goto-char (point-min)) + (while (re-search-forward "^==== \\([^#\n]+\\)#.*\n====" nil t) + (if (member (match-string 1) opened) + (progn + (setq empty-diff t) + (goto-char (point-max)))))))) + (kill-buffer buffer) + empty-diff)) + +;; this next chunk is not currently used, but my plan is to +;; reintroduce it as configurable bury-or-kill-on-q behaviour: + +;; (defcustom p4-blame-2ary-disp-method 'default +;; "Method to use when displaying p4-blame secondary buffers +;; (currently change and rev buffers) + +;; new-frame -- pop a new frame for the buffer +;; new-window -- create a new window for the buffer +;; default -- just do what `display-buffer' would do + +;; Any other value is equivalent to default." +;; :type '(radio (const default) (const new-frame) (const new-window)) +;; :group 'p4) + +(defun p4-blame-kill-blame () + "Don\'t ask any questions, just kill the current buffer" + (interactive) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + +(defun p4-blame-secondary-buffer-cleanup () + "Attempt to clean up a` p4-blame' secondary buffer neatly, deleting +windows or frames when we think that\'s necessary" + (let* ((this-buffer (current-buffer)) + (this-window (get-buffer-window this-buffer t))) + (cond + ;; in new-frame mode, delete the frame + ((eq p4-blame-2ary-disp-method 'new-frame) + (if (one-window-p 'ignore-minibuffer 'just-this-frame) + (delete-frame (window-frame this-window)) + (delete-window this-window)) t) + ;; in new-window mode, just zap the window, + ;; provided it is not the only one: + ((eq p4-blame-2ary-disp-method 'new-window) + (if (not (one-window-p 'ignore-minibuffer 'just-this-frame)) + (delete-window this-window)) t) + ;; any other mode, nothing special need be done + (t + t)))) + +(provide 'p4) + +;;; p4.el ends here diff --git a/emacs-lisp/modes/perl-stuff.el b/emacs-lisp/modes/perl-stuff.el new file mode 100644 index 0000000..d364f92 --- /dev/null +++ b/emacs-lisp/modes/perl-stuff.el @@ -0,0 +1,6 @@ +(add-hook 'cperl-mode-hook '(lambda () + (setq cperl-indent-level 3) + (setq indent-tabs-mode nil) +)) + +(provide 'perl-stuff) diff --git a/emacs-lisp/modes/plsql.el b/emacs-lisp/modes/plsql.el new file mode 100644 index 0000000..1c8aad2 --- /dev/null +++ b/emacs-lisp/modes/plsql.el @@ -0,0 +1,409 @@ +;; plsql.el -- PL/SQL Editing Major Mode
+;;
+;; Name: plsql.el
+;; Purpose: An emacs major Mode for editing PL/SQL code.
+;; Author: Neelakantan Krishnaswami
+;; Email: neelk@alum.mit.edu
+
+(defconst plsql-version "0.5"
+ "`plsql-mode' version number.")
+
+(defvar plsql-mode-hook nil
+ "*List of functions to call when entering PL/SQL major mode.")
+
+;; Font lock keywords.
+
+(defvar plsql-keywords (mapconcat
+ 'identity
+ '("\\<select\\>" "\\<from\\>" "\\<where\\>" "\\<into\\>"
+ "\\<delete\\>" "\\<insert\\>" "\\<drop\\>"
+ "\\<group\\>" "\\<order\\>" "\\<alter\\>"
+ "\\<having\\>" "\\<update\\>" "\\<values\\>"
+ "\\<open\\>" "\\<cursor\\>" "\\<close\\>" "\\<fetch\\>"
+ "\\<create\\>" "\\<replace\\>" "\\<package\\>"
+ "\\<body" "\\<is\\>" "\\<as\\>" "\\<or\\>"
+ "\\<and\\>" "\\<if\\>" "\\<then\\>" "\\<elsif\\>"
+ "\\<else" "\\<end if\\>" "\\<for\\>" "\\<while\\>"
+ "\\<exit\\>" "\\<loop\\>" "\\<end loop\\>"
+ "\\<declare\\>" "\\<begin\\>" "\\<end\\>"
+ "\\<function\\>" "\\<procedure\\>" "\\<return\\>"
+ "\\<default\\>" "\\<null\\>" "\\<not\\>"
+ "\\<true\\>" "\\<false\\>" "\\<between\\>" "\\<like\\>"
+ "\\<in\\>" "\\<out\\>" "\\<by\\>" "\\<index\\>"
+ "\\<of\\>" "\\<table\\>" "\\<record\\>"
+ "\\<exception\\>" "\\<when\\>" "\\<raise\\>"
+ "\\<commit\\>" "\\<truncate\\>" "\\<exists\\>"
+ "\\<distinct\\>"
+ )
+ "\\|")
+ "List of PL/SQL keywords, not counting types and builtins.")
+
+(defvar plsql-types (mapconcat 'identity
+ '("\\<NUMBER\\(([0-9\\s-]+)\\)?"
+ "\\<INTEGER\\>" "\\<BINARY_INTEGER\\>"
+ "\\<TYPE\\>" "\\<SUBTYPE\\>"
+ "\\<VARCHAR2\\(([0-9\\s-]+)\\)?"
+ "\\<CHAR\\(([0-9\\s-]+)\\)?"
+ "\\<DATE\\>" "\\<BOOLEAN\\>"
+ "\\<\\w+%ROWTYPE\\>" "\\<\\w+%TYPE\\>"
+ )
+ "\\|" )
+ "The basic PL/SQL types.")
+
+(defvar plsql-identifier "[a-z][a-z0-9_]*"
+ "Regexp matching legal PL/SQL identifiers.")
+
+(defvar plsql-type-identifier "[a-z][a-z0-9_\.]*\\(([0-9,\\s-]*)\\)?"
+ "Regexp matching type declarations and package elements.")
+
+(defvar plsql-default-value ".+"
+ "Somewhat crufty and imprecise regexp matching the default assignments in
+PL/SQL variable declations.")
+
+(defvar plsql-variable-declaration (concat "\\(" plsql-identifier "\\)"
+ "\\s-+"
+ "\\(" plsql-types "\\)"
+ "\\s-*"
+ "\\(\\(DEFAULT\\|:=\\)\\s-*"
+ plsql-default-value
+ "\\)?\\s-*[;]"
+ )
+ "Regexp matching a PL/SQL variable declaration. Contains `plsql-identifier',
+`plsql-types', and `plsql-default-value' regexps.")
+
+(defvar plsql-builtin-functions (mapconcat 'identity
+ '("\\<COUNT\\>" "\\<SUM\\>"
+ "\\<AVG\\>" "\\<VARIANCE\\>"
+ "\\<STDDEV\\>" "\\<MAX\\>"
+ "\\<MIN\\>"
+ "\\<ABS\\>" "\\<CEIL\\>"
+ "\\<COS\\>" "\\<COSH\\>"
+ "\\<EXP\\>" "\\<FLOOR\\>"
+ "\\<LN\\>" "\\<LOG\\>"
+ "\\<MOD\\>" "\\<POWER\\>"
+ "\\<ROUND\\>" "\\<SIGN\\>"
+ "\\<SIN\\>" "\\<SINH\\>"
+ "\\<SQRT\\>" "\\<TAN\\>"
+ "\\<TANH\\>" "\\<TRUNC\\>"
+ "\\<ADD_MONTHS\\>" "\\<LAST_DAY\\>"
+ "\\<MONTHS_BETWEEN\\>"
+ "\\<NEW_TIME\\>" "\\<NEXT_DAY\\>"
+ "\\<SYSDATE\\>"
+ "\\<DECODE\\>" "\\<NVL\\>"
+ "\\<CHR\\>" "\\<CONCAT\\>"
+ "\\<INITCAP\\>" "\\<LOWER\\>"
+ "\\<LPAD\\>" "\\<LTRIM\\>"
+ "\\<REPLACE\\>" "\\<RPAD\\>"
+ "\\<RTRIM\\>" "\\<SOUNDEX\\>"
+ "\\<SUBSTR\\>" "\\<SUBSTRB\\>"
+ "\\<TRANSLATE\\>" "\\<UPPER\\>"
+ "\\<LENGTH\\>" "\\<INSTR\\>"
+ "\\<TO_CHAR\\>" "\\<TO_DATE\\>"
+ "\\<TO_NUMBER\\>")
+ "\\|")
+ "Regexp matching PL/SQL's built in functions. It's not complete, but
+it contains all the ones I regularly use.")
+
+(defvar plsql-sqlplus-substitution-var (concat "&&?"
+ plsql-identifier
+ "\\>")
+ "Regexp to highlight SQLPLUS substitutions in PL/SQL code, of the
+form &[&]FOO.")
+
+(defvar plsql-function-declaration (concat "\\("
+ "FUNCTION\\|PROCEDURE\\|"
+ "BODY\\|PACKAGE"
+ "\\)"
+ "\\s-+"
+ "\\(" plsql-identifier "\\)"
+ )
+ "Regexp that matches procedure, function and package declaration
+statements, so that they may be highlighted.")
+
+(defvar plsql-font-lock-keywords
+ (list
+ (cons plsql-keywords 'font-lock-keyword-face)
+ (cons plsql-types 'font-lock-type-face)
+ (cons plsql-builtin-functions 'font-lock-builtin-face)
+ (cons plsql-sqlplus-substitution-var 'font-lock-warning-face)
+ (cons plsql-function-declaration
+ '(2 font-lock-function-name-face nil nil))
+ (cons plsql-variable-declaration
+ '(1 font-lock-variable-name-face nil nil))
+ )
+ "This is the list that gets assigned to `font-lock-defaults'.")
+
+
+;; Syntax Table Entries, to handle quoting and comments.
+
+(defvar plsql-syntax-table (make-syntax-table)
+ "The PL/SQL syntax table. This should be set more carefully, but comments
+and names are highlighted correctly so I'm too lazy to be more precise.")
+
+;; Syntax classes -- " for quotations,
+;; For comments, '-' 12,
+;; newline '>'
+;; '/' 12b
+;; '*' 23b
+(modify-syntax-entry (string-to-char "'") "\"" plsql-syntax-table)
+(modify-syntax-entry (string-to-char "-") ". 12" plsql-syntax-table)
+(modify-syntax-entry (string-to-char "\^J") ">" plsql-syntax-table)
+(modify-syntax-entry (string-to-char "/") ". 14b" plsql-syntax-table)
+(modify-syntax-entry (string-to-char "*") ". 23b" plsql-syntax-table)
+(modify-syntax-entry (string-to-char "_") "w " plsql-syntax-table)
+
+;;
+
+;; First, define the cursor-motion functions.
+
+(defvar plsql-indent-pattern (mapconcat 'identity
+ '("\\s-*EXCEPTION\\s-*$"
+ "\\<DELETE\\>"
+ "\\<UPDATE\\>"
+ "\\<DECLARE\\>"
+ "\\<RETURN.*IS\\>"
+ "\\<BEGIN\\>"
+ "\\<LOOP\\>"
+ "\\<CURSOR.*IS\\>"
+ "\\<THEN\\>"
+ "\\<ELSE\\>"
+ "\\<ELSIF\\>"
+ "\\<PACKAGE\\>"
+ "\\<TYPE[^;]*$"
+ "\\<CURSOR.*IS\\>"
+ "\\<CREATE\\s-+TABLE[^;]*$")
+ "\\|")
+ "`plsql-extra-indent-p' uses this regexp to determine whether or not
+the current line should receive an extra indent. See also
+`plsql-indent-cancel-pattern'.")
+
+(defvar plsql-select-pattern "\\<SELECT[^;]*$"
+ "This regexp is used by the `plsql-indent-to-select' function to determine
+whether or not to indent.")
+
+(defvar plsql-indent-cancel-pattern (concat "\\<END\\>"
+ "\\|"
+ "\\<FOR UPDATE\\>")
+ "This regexp is used by `plsql-extra-indent-p' to determine whether a
+potential extra indent is real or a fake caused by the inclusion of the
+keywords in block-closing statements (eg, ``END IF;''). See also
+`plsql-indent-pattern'.")
+
+
+(defun plsql-extra-indent-p (string)
+ "Determine whether or not STRING should get extra syntactic indentation.
+
+If string matches plsql-indent-pattern and *doesn't* match
+plsql-indent-cancel-pattern, then it will return true, and nil
+otherwise. Basically, this function will return true if the string
+contained an expression that requires the block to be indented."
+ (if (and (string-match plsql-indent-pattern string)
+ (not (string-match plsql-indent-cancel-pattern string)))
+ t
+ nil))
+
+(defun plsql-goto-previous-nonblank-line ()
+ (if (= (forward-line -1) 0)
+ (if (string-match "^\\s-*$" (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position)))
+ (plsql-goto-previous-nonblank-line))))
+
+(defun plsql-indent-line-function ()
+ "Indent the current line to the point PL/SQL code requires.
+
+This function will indent the current line to the next indent point
+in the previous nonblank line. Then, if the previous nonblank contained
+a substring that matched the plsql-indent-pattern, it will also call
+`tab-to-tab-stop'."
+ (interactive)
+ (let ((prev-line (save-excursion (plsql-goto-previous-nonblank-line)
+ (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position)))))
+ (if (string-match "^\\s-+" prev-line)
+ (indent-relative))
+ (if (plsql-extra-indent-p prev-line)
+ (tab-to-tab-stop))))
+
+(defun plsql-indent-to-select ()
+ "Indent a line to deal appropriately with SELECT statements."
+ (interactive)
+ (let* ((prev-line (save-excursion (plsql-goto-previous-nonblank-line)
+ (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position))))
+ (index (string-match plsql-select-pattern prev-line)))
+ (if index
+ (progn (message "%d" index)
+ (indent-to-column (string-width (substring prev-line
+ 0
+ index)))
+ (tab-to-tab-stop)))))
+
+;; (defun plsql-indent-line-function ()
+;; "Indent the current line to the point PL/SQL code requires.
+;;
+;; This function will indent the current line to the next indent point
+;; in the previous nonblank line. Then, if the previous nonblank contained
+;; a substring that matched the plsql-indent-pattern, it will also call
+;; `tab-to-tab-stop'."
+;; (interactive)
+;; (indent-relative)
+;; (if (save-excursion (plsql-goto-previous-nonblank-line)
+;; (plsql-extra-indent-p (buffer-substring-no-properties
+;; (line-beginning-position)
+;; (line-end-position))))
+;; (tab-to-tab-stop)))
+;;
+(defun plsql-electric-newline ()
+ "Intelligently indent new lines.
+
+If point is at column 0 when newline is pressed, just call `newline';
+otherwise, also call `plsql-indent-line-function'."
+ (interactive)
+ (let ((col (current-column)))
+ (newline)
+ (if (> col 0)
+ (progn
+ (plsql-indent-line-function)
+ (plsql-indent-to-select)))))
+
+(defun plsql-untabify-line-to-point ()
+ "Untabify the current line from the beginning to point.
+
+This function is used by `plsql-electric-backspace' to properly step
+backwards through indentation levels, without munging the spaces and
+tabs."
+ (interactive)
+ (let ((c (current-column)))
+ (untabify (line-beginning-position) (point))
+ (move-to-column c)))
+
+(defun plsql-tabify-line-to-point ()
+ "Tabify the current line from the beginning to point.
+
+This function is used by `plsql-electric-backspace' to restore the
+tabification to what it was prior to deleting an indentation level."
+ (interactive)
+ (let ((c (current-column)))
+ (tabify (line-beginning-position) (point))
+ (move-to-column c)))
+
+(defun plsql-find-glb-list (col lst)
+ "Find the largest element of lst smaller than col.
+
+This function assumes that lst is an ordered list, running from
+smallest to greatest. If col is bigger than the largest element of
+the list, the largest element is returned. If col is smaller than the
+smallest element, then 0 is returned. (Yes, this implicitly assumes
+that col and all the elements of lst are greater than 0.)"
+ (cond ((or (null lst)
+ (> (car lst) col))
+ 0)
+ ((null (cdr lst))
+ (car lst))
+ ((and (> col (car lst))
+ (<= col (cadr lst)))
+ (car lst))
+ (t
+ (plsql-find-glb-list col (cdr lst)))))
+
+(defun plsql-find-glb-tab-stop (col)
+ "Return the column position of the biggest tab stop less than col.
+
+This function calls `plsql-find-glb-tab-stop' on the list `tab-stop-list'."
+ (interactive "N")
+ (plsql-find-glb-list col tab-stop-list))
+
+(defun plsql-delete-to-previous-tab-stop ()
+ "Delete all the characters between the current column and the previous tab
+stop.
+
+This function tabifies the line, and it also stores the deleted characters
+in the kill ring."
+ (interactive)
+ (plsql-untabify-line-to-point)
+ (delete-backward-char (- (current-column)
+ (plsql-find-glb-tab-stop (current-column)))
+ t)
+ (plsql-tabify-line-to-point))
+
+(defun plsql-electric-backspace ()
+ "The backspace command for PL/SQL mode.
+
+This function first checks to see if there are any nonblank characters to
+its left on the same line. If there are, then one character is deleted, with
+`delete-backward-char'. If there is only whitespace to the left, then the
+function `plsql-delete-to-previous-tab-stop' is called and that happens."
+ (interactive)
+ (let ((line-to-point (buffer-substring-no-properties
+ (line-beginning-position)
+ (point))))
+ (if (string-match "^\\s-+$" line-to-point)
+ (plsql-delete-to-previous-tab-stop)
+ (delete-backward-char 1))))
+
+
+;; Mode-specific keymap
+
+(setq plsql-mode-map (copy-keymap text-mode-map))
+
+(define-key plsql-mode-map "\n" 'plsql-electric-newline)
+(define-key plsql-mode-map "\C-m" 'plsql-electric-newline)
+(define-key plsql-mode-map "\^?" 'plsql-electric-backspace)
+
+;;; Finally, define the major mode.
+
+(defun plsql-mode ()
+ "Major mode for editing PL/SQL code.
+
+Yes, this mode should be better documented. :)
+
+The big thing to remember is that the indentation levels are set by
+the variable `tab-stop-list'. Here's the line I use in my .emacs
+file to set a four-space indent:
+
+(setq tab-stop-list
+ '(4 8 12 16 20 24 28 32 36 40 44 48 52 56 60 64 68 72 76 80))
+
+The other keys are fairly intuitive. Backspace will delete a character,
+unless there is only whitespace to the left, in which case it will
+drop down indentation levels. Tab will first move to the indentation
+levels on the previous nonblank line, and then step through the tab
+stops.
+
+Future changes:
+
+o Comment lines count for indentation. This is highly annoying, and
+ will be fixed real soon now.
+
+o It's a pain to insert newlines. Soon, a newline inserted when the
+ cursor is in column zero won't auto-indent.
+
+o Pie-in-the-sky: Eventually, more features like the mode remembering
+ type declarations and fontifying intelligently based on that, and
+ retaining lists of function declarations, and even more exotic
+ possibility."
+
+ (interactive)
+ (kill-all-local-variables)
+ (indented-text-mode)
+ (setq major-mode 'plsql-mode)
+ (setq mode-name "PL/SQL")
+ (use-local-map plsql-mode-map)
+ (set-syntax-table plsql-syntax-table)
+ (make-local-variable 'font-lock-defaults)
+ (make-local-variable 'indent-line-function)
+ (setq font-lock-defaults '(plsql-font-lock-keywords
+ nil ;; Keywords-only?
+ t ;; Case-fold?
+ nil ;; Syntax-alist
+ nil ;; Syntax-begin
+ )
+ indent-line-function 'plsql-indent-line-function)
+ (run-hooks 'plsql-mode-hook))
+
+(provide 'plsql)
+
+;;; End plsql.el
diff --git a/emacs-lisp/modes/vala-mode.el b/emacs-lisp/modes/vala-mode.el new file mode 100644 index 0000000..0358790 --- /dev/null +++ b/emacs-lisp/modes/vala-mode.el @@ -0,0 +1,395 @@ +;;; vala-mode.el --- Vala mode derived mode + +;; Author: 2005 Dylan R. E. Moonfire +;; 2008 Étienne BERSAC +;; Maintainer: Étienne BERSAC <bersace03@laposte.net> +;; Created: 2008 May the 4th +;; Modified: May 2008 +;; Version: 0.1 +;; Keywords: vala languages oop + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; See http://live.gnome.org/Vala for details about Vala language. +;; +;; This is a separate mode to implement the Vala constructs and +;; font-locking. It is mostly the csharp-mode from +;; http://mfgames.com/linux/csharp-mode with vala specific keywords +;; and filename suffixes. +;; +;; Note: The interface used in this file requires CC Mode 5.30 or +;; later. + +;;; .emacs (don't put in (require 'vala-mode)) +;; (autoload 'vala-mode "vala-mode" "Major mode for editing Vala code." t) +;; (setq auto-mode-alist +;; (append '(("\\.vala$" . vala-mode)) auto-mode-alist)) + +;;; Versions: +;; +;; 0.1 : Initial version based on csharp-mode +;; + +;; This is a copy of the function in cc-mode which is used to handle +;; the eval-when-compile which is needed during other times. +(defun c-filter-ops (ops opgroup-filter op-filter &optional xlate) + ;; See cc-langs.el, a direct copy. + (unless (listp (car-safe ops)) + (setq ops (list ops))) + (cond ((eq opgroup-filter t) + (setq opgroup-filter (lambda (opgroup) t))) + ((not (functionp opgroup-filter)) + (setq opgroup-filter `(lambda (opgroup) + (memq opgroup ',opgroup-filter))))) + (cond ((eq op-filter t) + (setq op-filter (lambda (op) t))) + ((stringp op-filter) + (setq op-filter `(lambda (op) + (string-match ,op-filter op))))) + (unless xlate + (setq xlate 'identity)) + (c-with-syntax-table (c-lang-const c-mode-syntax-table) + (delete-duplicates + (mapcan (lambda (opgroup) + (when (if (symbolp (car opgroup)) + (when (funcall opgroup-filter (car opgroup)) + (setq opgroup (cdr opgroup)) + t) + t) + (mapcan (lambda (op) + (when (funcall op-filter op) + (let ((res (funcall xlate op))) + (if (listp res) res (list res))))) + opgroup))) + ops) + :test 'equal))) + +;; This inserts the bulk of the code. +(require 'cc-mode) + +;; These are only required at compile time to get the sources for the +;; language constants. (The cc-fonts require and the font-lock +;; related constants could additionally be put inside an +;; (eval-after-load "font-lock" ...) but then some trickery is +;; necessary to get them compiled.) +(eval-when-compile + (let ((load-path + (if (and (boundp 'byte-compile-dest-file) + (stringp byte-compile-dest-file)) + (cons (file-name-directory byte-compile-dest-file) load-path) + load-path))) + (load "cc-mode" nil t) + (load "cc-fonts" nil t) + (load "cc-langs" nil t))) + +(eval-and-compile + ;; Make our mode known to the language constant system. Use Java + ;; mode as the fallback for the constants we don't change here. + ;; This needs to be done also at compile time since the language + ;; constants are evaluated then. + (c-add-language 'vala-mode 'java-mode)) + +;; Java uses a series of regexes to change the font-lock for class +;; references. The problem comes in because Java uses Pascal (leading +;; space in names, SomeClass) for class and package names, but +;; Camel-casing (initial lowercase, upper case in words, +;; i.e. someVariable) for variables. +;;(error (byte-compile-dest-file)) +;;(error (c-get-current-file)) +(c-lang-defconst c-opt-after-id-concat-key + vala (if (c-lang-const c-opt-identifier-concat-key) + (c-lang-const c-symbol-start))) + +(c-lang-defconst c-basic-matchers-before + vala `( +;;;; Font-lock the attributes by searching for the +;;;; appropriate regex and marking it as TODO. + ;;,`(,(concat "\\(" vala-attribute-regex "\\)") + ;; 0 font-lock-function-name-face) + + ;; Put a warning face on the opener of unclosed strings that + ;; can't span lines. Later font + ;; lock packages have a `font-lock-syntactic-face-function' for + ;; this, but it doesn't give the control we want since any + ;; fontification done inside the function will be + ;; unconditionally overridden. + ,(c-make-font-lock-search-function + ;; Match a char before the string starter to make + ;; `c-skip-comments-and-strings' work correctly. + (concat ".\\(" c-string-limit-regexp "\\)") + '((c-font-lock-invalid-string))) + + ;; Fontify keyword constants. + ,@(when (c-lang-const c-constant-kwds) + (let ((re (c-make-keywords-re nil + (c-lang-const c-constant-kwds)))) + `((eval . (list ,(concat "\\<\\(" re "\\)\\>") + 1 c-constant-face-name))))) + + ;; Fontify all keywords except the primitive types. + ,`(,(concat "\\<" (c-lang-const c-regular-keywords-regexp)) + 1 font-lock-keyword-face) + + ;; Fontify leading identifiers in fully + ;; qualified names like "Foo.Bar". + ,@(when (c-lang-const c-opt-identifier-concat-key) + `((,(byte-compile + `(lambda (limit) + (while (re-search-forward + ,(concat "\\(\\<" ; 1 + "\\(" (c-lang-const c-symbol-key) + "\\)" ; 2 + "[ \t\n\r\f\v]*" + (c-lang-const + c-opt-identifier-concat-key) + "[ \t\n\r\f\v]*" + "\\)" + "\\(" + (c-lang-const + c-opt-after-id-concat-key) + "\\)") + limit t) + (unless (progn + (goto-char (match-beginning 0)) + (c-skip-comments-and-strings limit)) + (or (get-text-property (match-beginning 2) 'face) + (c-put-font-lock-face (match-beginning 2) + (match-end 2) + c-reference-face-name)) + (goto-char (match-end 1))))))))) + )) + +;; Vala does not allow a leading qualifier operator. It also doesn't +;; allow the ".*" construct of Java. So, we redo this regex without +;; the "\\|\\*" regex. +(c-lang-defconst c-identifier-key + vala (concat "\\(" (c-lang-const c-symbol-key) "\\)" ; 1 + (concat "\\(" + "[ \t\n\r\f\v]*" + (c-lang-const c-opt-identifier-concat-key) + "[ \t\n\r\f\v]*" + (concat "\\(" + "\\(" (c-lang-const c-symbol-key) "\\)" + "\\)") + "\\)*"))) + +;; Vala has a few rules that are slightly different than Java for +;; operators. This also removed the Java's "super" and replaces it +;; with the Vala's "base". +(c-lang-defconst c-operators + vala `((prefix "base"))) + +;; Vala directives ? +;; (c-lang-defconst c-opt-cpp-prefix +;; csharp "^\\s *#.*") + + +;; Vala uses the following assignment operators +(c-lang-defconst c-assignment-operators + vala '("=" "*=" "/=" "%=" "+=" "-=" ">>=" "<<=" + "&=" "^=" "|=" "++" "--")) + +;; This defines the primative types for Vala +(c-lang-defconst c-primitive-type-kwds + vala '("void" "char" "int" "float" "double" "string")) + +;; The keywords that define that the following is a type, such as a +;; class definition. +(c-lang-defconst c-type-prefix-kwds + vala '("class" "interface" "struct" "enum" "signal")) + +;; Type modifier keywords. They appear anywhere in types, but modifiy +;; instead create one. +(c-lang-defconst c-type-modifier-kwds + vala '("const")) + +;; Structures that are similiar to classes. +(c-lang-defconst c-class-decl-kwds + vala '("class" "interface")) + +;; The various modifiers used for class and method descriptions. +(c-lang-defconst c-modifier-kwds + vala '("public" "partial" "private" "const" "abstract" + "protected" "ref" "in" "out" "static" "virtual" + "override" "params" "internal" "weak" "owned" + "unowned")) + +;; We don't use the protection level stuff because it breaks the +;; method indenting. Not sure why, though. +(c-lang-defconst c-protection-kwds + vala nil) + +;; Define the keywords that can have something following after them. +(c-lang-defconst c-type-list-kwds + vala '("struct" "class" "interface" "is" "as" + "delegate" "event" "set" "get" "add" "remove" + "callback" "signal" "var" "default")) + +;; This allows the classes after the : in the class declartion to be +;; fontified. +(c-lang-defconst c-typeless-decl-kwds + vala '(":")) + +;; Sets up the enum to handle the list properly +(c-lang-defconst c-brace-list-decl-kwds + vala '("enum" "errordomain")) + +;; We need to remove Java's package keyword +(c-lang-defconst c-ref-list-kwds + vala '("using" "namespace" "construct")) + +;; Follow-on blocks that don't require a brace +(c-lang-defconst c-block-stmt-2-kwds + vala '("for" "if" "switch" "while" "catch" "foreach" "lock")) + +;; Statements that break out of braces +(c-lang-defconst c-simple-stmt-kwds + vala '("return" "continue" "break" "throw")) + +;; Statements that allow a label +;; TODO? +(c-lang-defconst c-before-label-kwds + vala nil) + +;; Constant keywords +(c-lang-defconst c-constant-kwds + vala '("true" "false" "null")) + +;; Keywords that start "primary expressions." +(c-lang-defconst c-primary-expr-kwds + vala '("this" "base")) + +;; We need to treat namespace as an outer block to class indenting +;; works properly. +(c-lang-defconst c-other-block-decl-kwds + vala '("namespace")) + +;; We need to include the "in" for the foreach +(c-lang-defconst c-other-kwds + vala '("in" "sizeof" "typeof")) + +(require 'cc-awk) + +(c-lang-defconst c-at-vsemi-p-fn + vala 'c-awk-at-vsemi-p) + + +(defcustom vala-font-lock-extra-types nil + "*List of extra types (aside from the type keywords) to recognize in Vala mode. +Each list item should be a regexp matching a single identifier.") + +(defconst vala-font-lock-keywords-1 (c-lang-const c-matchers-1 vala) + "Minimal highlighting for Vala mode.") + +(defconst vala-font-lock-keywords-2 (c-lang-const c-matchers-2 vala) + "Fast normal highlighting for Vala mode.") + +(defconst vala-font-lock-keywords-3 (c-lang-const c-matchers-3 vala) + "Accurate normal highlighting for Vala mode.") + +(defvar vala-font-lock-keywords vala-font-lock-keywords-3 + "Default expressions to highlight in Vala mode.") + +(defvar vala-mode-syntax-table + nil + "Syntax table used in vala-mode buffers.") +(or vala-mode-syntax-table + (setq vala-mode-syntax-table + (funcall (c-lang-const c-make-mode-syntax-table vala)))) + +(defvar vala-mode-abbrev-table nil + "Abbreviation table used in vala-mode buffers.") +(c-define-abbrev-table 'vala-mode-abbrev-table + ;; Keywords that if they occur first on a line + ;; might alter the syntactic context, and which + ;; therefore should trig reindentation when + ;; they are completed. + '(("else" "else" c-electric-continued-statement 0) + ("while" "while" c-electric-continued-statement 0) + ("catch" "catch" c-electric-continued-statement 0) + ("finally" "finally" c-electric-continued-statement 0))) + +(defvar vala-mode-map (let ((map (c-make-inherited-keymap))) + ;; Add bindings which are only useful for Vala + map) + "Keymap used in vala-mode buffers.") + +;;(easy-menu-define vala-menu vala-mode-map "Vala Mode Commands" +;; ;; Can use `vala' as the language for `c-mode-menu' +;; ;; since its definition covers any language. In +;; ;; this case the language is used to adapt to the +;; ;; nonexistence of a cpp pass and thus removing some +;; ;; irrelevant menu alternatives. +;; (cons "Vala" (c-lang-const c-mode-menu vala))) + +;;; Autoload mode trigger +(add-to-list 'auto-mode-alist '("\\.vala$" . vala-mode)) +(add-to-list 'auto-mode-alist '("\\.vapi$" . vala-mode)) + +;; Custom variables +(defcustom vala-mode-hook nil + "*Hook called by `vala-mode'." + :type 'hook + :group 'c) + +;;; The entry point into the mode +;;;###autoload +(defun vala-mode () + "Major mode for editing Vala code. +This is a simple example of a separate mode derived from CC Mode +to support a language with syntax similar to +C#/C/C++/ObjC/Java/IDL/Pike. + +The hook `c-mode-common-hook' is run with no args at mode +initialization, then `vala-mode-hook'. + +Key bindings: +\\{vala-mode-map}" + (interactive) + (kill-all-local-variables) + (c-initialize-cc-mode t) + (set-syntax-table vala-mode-syntax-table) + (setq major-mode 'vala-mode + mode-name "Vala" + local-abbrev-table vala-mode-abbrev-table + abbrev-mode t) + (use-local-map c-mode-map) + ;; `c-init-language-vars' is a macro that is expanded at compile + ;; time to a large `setq' with all the language variables and their + ;; customized values for our language. + (c-init-language-vars vala-mode) + ;; `c-common-init' initializes most of the components of a CC Mode + ;; buffer, including setup of the mode menu, font-lock, etc. + ;; There's also a lower level routine `c-basic-common-init' that + ;; only makes the necessary initialization to get the syntactic + ;; analysis and similar things working. + (c-common-init 'vala-mode) + ;;(easy-menu-add vala-menu) + (c-set-style "linux") + (setq indent-tabs-mode t) + (setq c-basic-offset 4) + (setq tab-width 4) + (c-toggle-auto-newline -1) + (c-toggle-hungry-state -1) + (run-hooks 'c-mode-common-hook) + (run-hooks 'vala-mode-hook) + (c-update-modeline)) + +(provide 'vala-mode) + +;;; vala-mode.el ends here diff --git a/emacs-lisp/modes/xtla.el b/emacs-lisp/modes/xtla.el new file mode 100644 index 0000000..c28873d --- /dev/null +++ b/emacs-lisp/modes/xtla.el @@ -0,0 +1,5497 @@ +;;; xtla.el --- Arch interface for emacs +;; Copyright (C) 2003-2004 by Stefan Reichoer + +;; Author: Stefan Reichoer, <xsteve@nit.at> +;; Contributions from: +;; Matthieu Moy <Matthieu.Moy@imag.fr> +;; Masatake YAMATO <jet@gyve.org> +;; Milan Zamazal <pdm@zamazal.org> +;; Martin Pool <mbp@sourcefrog.net> +;; Robert Widhopf-Fenk <hack@robf.de> +;; Mark Triggs <mst@dishevelled.net> + +;; xtla.el is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; xtla.el is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary + +;; Some documentation can be found on the wiki here +;; http://wiki.gnuarch.org/moin.cgi/xtla + +;; There is a project page at +;; https://gna.org/projects/xtla-el +;; You can subscribe to the mailing list via +;; https://mail.gna.org/listinfo/xtla-el-dev + +;; Usage: +;; put the following in your .emacs: (require 'xtla) + +;; The main commands are available with the prefix key C-x T. +;; Type C-x T C-h for a list. + +;; M-x tla-inventory shows a tla inventory +;; In this inventory buffer the following commands are available: +;; e ... tla-edit-log +;; d ... tla-changes +;; l ... tla-changelog +;; L ... tla-logs + +;; To Edit a logfile issue: M-x tla-edit-log +;; In this mode you can hit C-c C-d to show the changes +;; Edit the log file +;; After that you issue M-x tla-commit (bound to C-c C-c) to commit the files + +;; M-x tla-archives starts the interactive archive browser + +;; M-x tla-make-archive creates a new archive directory +;; Many commands are available from here. Look at the menus, they're +;; very helpfull to begin. + +;; M-x tla-bookmarks RET +;; Is another good starting point. This is the place where you put the +;; project you work on most often, and you can get a new version, see +;; the missing patches, and a few other usefull features from here. +;; Use `a' to add a bookmark. Add your own projects, and your +;; contributor's projects too. Select several related projects with +;; `m' (unselect with M-u or M-del). Make them partners with 'M-p'. +;; Now, with your cursor on a bookmark, view the uncommited changes, +;; the missing patches from your archive and your contributors with +;; 'M'. + +;; M-x tla-file-ediff RET +;; Is an wrapper to tla file-diff, ediff to view the changes +;; interactively. + +;; Misc commands: +;; tla-insert-arch-tag inserts a arch-tag entry generated with uuidgen + +;; There is an arch archive for xtla.el at: http://xsteve.nit.at/tla +;; Just type: M-x tla-register-archive <RET> http://xsteve.nit.at/tla <RET> +;; M-x tla-archives <RET> +;; With these commands you can start to browse the archive + +;; If you find xtla.el useful, and you have some ideas to improve it +;; please share them with me (Patches are preferred :-)) + +;; todo: +;; Many things +;; +;; * autoload marks +;; * interface for tla abrowse +;; * dired extension for tla files and operations +;; * modes for tla related files. +;; * run tla-tree-lint in compilation mode. + +;; ---------------------------------------------------------------------------- +;; User customization section +;; ---------------------------------------------------------------------------- + +;;;###autoload +(defgroup xtla nil + "Arch interface for emacs." + :group 'tools + :prefix "tla-") + +;;;###autoload +(defvar tla-global-keymap () "Global keymap used by Xtla") + +;;;###autoload +(defvar tla-ediff-keymap () + "Global keymap used by Xtla in the ediff control buffer") + +;;;###autoload +(defun tla--set-prefix-key (var value) + "custom-set function to change the prefix key. + +Removes the previous binding and applies the new one." + (if (boundp var) + (global-unset-key (symbol-value var))) + (set var value) + (global-set-key (symbol-value var) tla-global-keymap)) + +;;;###autoload +(defcustom tla-prefix-key [(control x) ?T] + "Prefix key for most xtla commands" + :type 'sexp + :group 'xtla + :set 'tla--set-prefix-key) +;; There doesn't seem to be a customization type for keybindings, so +;; sexp is the closest.(?) + +;;;###autoload +(defcustom tla-tla-executable "tla" + "*The name of the tla executable" + :type 'string + :group 'xtla) + +;;;###autoload +(defcustom tla-diff-executable "diff" + "*The name of the diff executable" + :type 'string + :group 'xtla) + +;;;###autoload +(defcustom tla-patch-executable "patch" + "*The name of the patch executable" + :type 'string + :group 'xtla) + +;;;###autoload +(defcustom tla-highlight t + "*Use highlighting for tla buffers" + :type 'boolean + :group 'xtla) + +;;;###autoload +(defcustom tla-install-command-help-system t + "*Use f1 to display help for the actual function call during minibuffer input. +Note: this functionality is provided for all minibuffer prompts." + :type 'boolean + :group 'xtla) + +;;;###autoload +(defcustom tla-do-not-prompt-for-save nil + "*If non nil, xtla will not prompt you before saving buffers of the +working local tree" + :type 'boolean + :group 'xtla) + +;;;###autoload +(defcustom tla-automatically-revert-buffers t + "*If non nil, xtla will automatically revert unmodified buffers +after an arch operation modifying the file." + :type 'boolean + :group 'xtla) + +;;;###autoload +(defcustom tla-strict-commits nil + "*If non-nil, commit operations are invoked with the --strict option." + :type 'boolean + :group 'xtla) + +;;;###autoload +(defcustom tla-three-way-merge nil + "*If non-nil, star-merge operations are invoked with the --three-way +option." + :type 'boolean + :group 'xtla) + +;;;###autoload +(defgroup tla-bookmarks nil + "xtla bookmarks allows you to save places (archive, category, +branch, version) in the archive that you use often. Try M-x +tla-bookmarks RET to see." + :group 'xtla) + +;;;###autoload +(defcustom tla-bookmarks-file-name "~/.tla-bookmarks.el" + "*File in which xtla bookmarks will be saved" + :type 'file + :group 'xtla-bookmarks) + +;;;###autoload +(defcustom tla-bookmarks-cleanup-dont-prompt nil + "*non nil means `tla-bookmarks-cleanup-local-trees' shouldn't prompt +before removing a local-tree" + :type 'boolean + :group 'xtla-bookmarks) + +;;;###autoload +(defgroup xtla-internal nil + "This group contains items used mainly for debugging." + :group 'xtla) + +;;;###autoload +(defcustom tla-log-commands t + "*Non nil means log all tla executed commands in the buffer +*tla-log*." + :type 'boolean + :group 'xtla-internal) + +;;;###autoload +(defcustom tla-process-buffer " *tla-process*" + "*Name of the process buffer" + :type 'string + :group 'xtla-internal) + +;;;###autoload +(defcustom tla-error-buffer " *tla-errors*" + "*Name of the buffer to which tla's stderr is redirected" + :type 'string + :group 'xtla-internal) + +;;;###autoload +(defcustom tla-log-buffer " *tla-log*" + "*Name of the buffer in which xtla logs main events" + :type 'string + :group 'xtla-internal) + +;;;###autoload +(defcustom tla-switch-to-buffer-mode 'pop-to-buffer + "*Mode for switching to xtla buffers." + :type '(choice (const pop-to-buffer) + (const single-window) + (const dedicated-frame)) + :group 'xtla) + +;;;###autoload +(defcustom tla-log-insert-last t + "*If non-nil, new changelog entries will be inserted at the end of +the log file" + :type 'boolean + :group 'xtla) + + + +;;;###autoload +(defface tla-marked + '((((type tty) (class color)) (:foreground "magenta" :weight light)) + (((class color) (background light)) (:foreground "magenta")) + (((class color) (background dark)) (:foreground "yellow")) + (t (:weight bold))) + "Face to highlight a marked entry in xtla buffers" + :group 'xtla-faces) + +;;;###autoload +(defface tla-archive-name + '((((type tty) (class color)) (:foreground "lightblue" :weight light)) + (((class color) (background light)) (:foreground "blue4")) + (((class color) (background dark)) (:foreground "lightskyblue1")) + (t (:weight bold))) + "Face to highlight xtla archive names." + :group 'xtla-faces) + +;;;###autoload +(defface tla-category-name + '((t (:inherit xtla-archive-name))) + "Face to highlight xtla category names." + :group 'xtla-faces) + +;;;###autoload +(defface tla-branch-name + '((t (:inherit xtla-archive-name))) + "Face to highlight xtla branch names." + :group 'xtla-faces) + +;;;###autoload +(defface tla-version-name + '((t (:inherit tla-archive-name))) + "Face to highlight xtla version names." + :group 'xtla-faces) + +;;;###autoload +(defface tla-revision-name + '((t (:inherit tla-archive-name))) + "Face to highlight xtla revision names." + :group 'xtla-faces) + +;;;###autoload +(defface tla-bookmark-name + '((t (:inherit tla-archive-name))) + "Face to highlight xtla revision names." + :group 'xtla-faces) + +;;;###autoload +(defface tla-separator + '((((background light)) (:underline t :bold t)) + (((background dark)) (:underline t :bold t))) + "Face to highlight separators." + :group 'xtla-faces) + +;; ---------------------------------------------------------------------------- +;; End of customization section +;; ---------------------------------------------------------------------------- + +(eval-when-compile + (require 'cl) + (require 'ediff)) + +(require 'ewoc) +(require 'diff-mode) + +;; ---------------------------------------------------------------------------- +;; Internal variables +;; ---------------------------------------------------------------------------- +(defvar tla-edit-arch-command nil) +(defvar tla-pre-commit-window-configuration nil) +(defvar tla-log-edit-file-name nil) +(defvar tla-log-edit-file-buffer nil) +(defvar tla-my-id-history nil) +(defvar tla-archive-tree nil) + +(defvar tla-buffer-archive-name nil) +(defvar tla-buffer-category-name nil) +(defvar tla-buffer-branch-name nil) +(defvar tla-buffer-version-name nil) +(defvar tla-buffer-refresh-function nil + "Variable should be local to each buffer. Function used to refresh +the current buffer") +(defvar tla-buffer-marked-file-list nil + "List of marked files in the current buffer.") +(defvar tla-get-revision-info-at-point-function nil + "Variable should be local to each buffer. +Function used to get the revision info at point") + +(defvar tla-mode-line-process "") +(defvar tla-mode-line-process-status "") + +(defvar tla-partner-select-was-interactive nil) + +;; Overlay category +(put 'tla-default-button 'mouse-face 'highlight) +(put 'tla-default-button 'evaporate t) +;;(put 'tla-default-button 'rear-nonsticky t) +;;(put 'tla-default-button 'front-nonsticky t) + +;; ---------------------------------------------------------------------------- +;; Compatibility stuff +;; ---------------------------------------------------------------------------- +(require 'overlay) ; needed for XEmacs + +(unless (fboundp 'read-directory-name) + (defalias 'read-directory-name 'read-file-name)) + +(unless (fboundp 'line-end-position) + (defun line-end-position () + (save-excursion (end-of-line) (point)))) + +(unless (fboundp 'replace-regexp-in-string) + (defun replace-regexp-in-string (regexp rep string) + (replace-in-string string regexp rep))) + +(unless (fboundp 'line-beginning-position) + (defun line-beginning-position (&optional n) + (save-excursion + (if n (forward-line n)) + (beginning-of-line) + (point)))) + +(unless (fboundp 'match-string-no-properties) + (defun match-string-no-properties (arg) + (match-string arg))) + +(defun xtla-diff-hunk-next (&optional count) + (if (featurep 'xemacs) + (diff-hunk-next count) + (diff-next-hunk))) + +(defun xtla-diff-hunk-prev (&optional count) + (if (featurep 'xemacs) + (diff-hunk-prev count) + (diff-prev-hunk))) + +;; ---------------------------------------------------------------------------- +;; Face manipulators +;; ---------------------------------------------------------------------------- +(defun tla-add-face (str face &optional keymap) + (if tla-highlight + (let ((strcpy (format "%s" str))) + (add-text-properties 0 (length strcpy) + `(face ,face + ,@(when keymap + `(mouse-face highlight + local-map ,keymap))) + strcpy) + strcpy) + str)) + +(defun tla-choose-face-to-add (condition text face1 face2) + "If condition then add face1 to text, else add face2 to text." + (if condition + (tla-add-face text face1) + (tla-add-face text face2))) + +;; ---------------------------------------------------------------------------- +;; Macros +;; ---------------------------------------------------------------------------- +(defmacro tla-toggle-list-entry (list entry) + "Either add or remove the entry from list" + `(if (member ,entry ,list) + (setq ,list (delete ,entry ,list)) + (add-to-list ',list ,entry))) + +(defvar tla-last-command "" + "Last command ran by `tla-run-arch'") + +(defvar tla-err-file "" + "File in which tla redirects its stdout") + +(defvar tla-process-sentinel-var 'tla-process-sentinel + "Function used as a sentinel for tla asynchron process. Don't use +setq on this variable, but set it temporarily with + (let ((tla-process-sentinel-var 'other-function)) + (tla-run-arch ...))") + +;; ---------------------------------------------------------------------------- +;; Tla process handler +;; ---------------------------------------------------------------------------- +;; If tla is run synchronous, `tla-run-arch' returns the exit status. +(defvar tla-process-associated-buffer nil + "Buffer from where the process was started. This variable is local +to the process in which the tla process executes, and points to +another buffer. In the process sentinel, we switch back to this +buffer for some tasks") + +(defvar tla-process-cmd nil + "Typd of process being run") + +(defvar tla-proc nil + "Current tla process") + +(defun tla-run-arch (run-asynchron clear-process-buffer cmdtype &rest arglist) + (let ((current-dir default-directory) + (from-buffer (current-buffer))) + (if (eq (process-status "arch") nil) + (progn + (when tla-edit-arch-command + (setq arglist (append arglist + (split-string + (read-from-minibuffer + (format "arch %s %S " cmdtype arglist))))) + (when (eq tla-edit-arch-command t) + (tla-toggle-edit-cmd-flag t)) + (message "tla-run-arch %s: %S" cmdtype arglist)) + (let* ((proc-buf (get-buffer-create tla-process-buffer)) + (err-file (make-temp-name "/tmp/arch-errors"))) + (when (listp (car arglist)) + (setq arglist (car arglist))) + (save-excursion + (set-buffer proc-buf) + (cd current-dir) + (setq buffer-read-only nil) + (fundamental-mode) + (if clear-process-buffer + (erase-buffer) + (goto-char (point-max))) + (set (make-local-variable + 'tla-process-associated-buffer) + from-buffer) + (with-current-buffer tla-process-buffer + (set (make-local-variable 'tla-process-cmd) cmdtype)) + (setq tla-mode-line-process-status (format " running %s" cmdtype)) + (tla-update-mode-line) + (sit-for 0.001) + (setq tla-last-command tla-tla-executable) + (dolist (x arglist) + (setq tla-last-command + (concat tla-last-command + " " (shell-quote-argument x)))) + (when tla-log-commands + (save-current-buffer + (let ((tree default-directory)) + (set-buffer (get-buffer-create tla-log-buffer)) + (goto-char (point-max)) + (insert "\nCommand: " tla-last-command + "\nDirectory: " tree + "\nDate: " (format-time-string "%c") + "\n")))) + (message "running %s ..." tla-last-command) + (if run-asynchron + (progn + (setq tla-err-file err-file) + (setq tla-proc (apply 'start-process "arch" + proc-buf + "sh" "-c" (list (concat + tla-last-command " 2>" + err-file)))) + (set-process-sentinel tla-proc + tla-process-sentinel-var)) + ;;(message "running synchron: tla %S" arglist) + (prog1 + (apply 'call-process tla-tla-executable nil + `(,(buffer-name proc-buf) ,err-file) + nil arglist) + (when (file-exists-p err-file) + (save-window-excursion + (set-buffer (get-buffer-create tla-error-buffer)) + (erase-buffer) + (let ((msg (progn (insert-file err-file) + (buffer-substring-no-properties + (point-min) + (point-max))))) + (when msg (message msg)))) + (delete-file err-file)) + (setq tla-mode-line-process-status "") + (tla-update-mode-line)))))) + (error "You can only run one arch process at once!")))) + +(defun tla-process-sentinel (process event) + ;;(princ (format "Process: %s had the event `%s'" process event))) + ;;(save-excursion + (when tla-log-commands + (with-current-buffer tla-log-buffer + (goto-char (point-max)) + (insert "\nProcess \"") + (dolist (x (process-command process)) + (insert x " ")) (delete-backward-char 1) + (insert "\"\n") + (insert "Event: " event + "Date: " (current-time-string) "\n"))) + (when (file-exists-p tla-err-file) + (save-window-excursion + (set-buffer (get-buffer-create tla-error-buffer)) + (erase-buffer) + (let ((msg (progn (insert-file tla-err-file) + (buffer-substring-no-properties + (point-min) + (point-max))))) + (when msg (message msg)))) + (delete-file tla-err-file)) + (let ((tla-process-cmd (with-current-buffer tla-process-buffer + tla-process-cmd))) + (set-buffer (process-buffer process)) + (set-buffer tla-process-associated-buffer) + (setq tla-mode-line-process-status "") + (tla-update-mode-line) + (cond ((string= event "finished\n") + (case tla-process-cmd + (archive-mirror (tla-show-process-buffer-internal t) + (message "tla archive-mirror finished")) + (star-merge (tla-show-process-buffer-internal t) + (tla-show-changes-buffer) + (message "tla star-merge finished") + ;; TODO is it really the right directory ? + (tla-revert-some-buffers default-directory)) + (delta (let ((no-changes)) + (save-excursion + (set-buffer tla-process-buffer) + (setq no-changes (= (- (point-max) (point-min)) 1))) + (if no-changes + (message "tla delta finished: No changes in this arch working copy") + (tla-show-changes-buffer) + (message "tla delta finished")))) + (missing-list (tla-bookmarks-missing-parse-missing) + (tla-bookmarks-missing-do-todolist)) + (changes-list (tla-bookmarks-missing-parse-changes) + (tla-bookmarks-missing-do-todolist)) + (changes (message "No changes in this working copy")) + (t (message "tla command finished")))) + ((string= event "killed\n") + (message "tla process killed")) + ((string-match "exited abnormally" event) + (cond ((and (eq tla-process-cmd 'changes-list) + (string-match "code 1$" event)) + ;; tla changes returns with an error code of 1 when + ;; there are some changes + (tla-bookmarks-missing-parse-changes) + (tla-bookmarks-missing-do-todolist)) + ((and (eq tla-process-cmd 'star-merge) + (string-match "code 1$" event)) + (tla-show-changes-buffer)) + ((and (eq tla-process-cmd 'changes) + (string-match "code 1$" event)) + (tla-show-changes-buffer)) + (t + (while (accept-process-output process 0 100)) + ;; find last error message and show it. + (goto-char (point-max)) + (message "tla failed: %s" + (if (re-search-backward "^tla: \\(.*\\)\n" nil t) + (match-string 1) + event))))) + (t + (message "tla process had unknown event: %s" event)) + (tla-show-process-buffer-internal t)))) + +(defun tla-show-process-buffer () + (interactive) + (tla-show-process-buffer-internal)) + + +(defun tla-show-process-buffer-internal (&optional scroll-to-top new-buffer-name mode-func) + "Show the result of tla process. +If SCROLL-TO-TOP is non-nil, the point is moved to the top of buffer. +If NEW-BUFFER-NAME(a string) is given, the shown buffer is renamed to it. +If MODE-FUNC(a function with no argument) is given, it is called with selecting shown buffer. +MODE-FUNC is assumed to use set up a buffer mode. " + (pop-to-buffer tla-process-buffer) + (when new-buffer-name + (if (get-buffer new-buffer-name) + (kill-buffer new-buffer-name)) + (rename-buffer new-buffer-name)) + (if mode-func + (funcall mode-func)) + (when scroll-to-top + (goto-char (point-min))) + (other-window 1)) + +(defun tla-get-process-output () + (save-excursion + (set-buffer tla-process-buffer) + (if (> (point-max) (point-min)) + (buffer-substring-no-properties (point-min) (- (point-max) 1)) + ""))) + +(defun tla-update-mode-line () + (setq tla-mode-line-process tla-mode-line-process-status) + ;; The following is not yet needed: + ;; (concat tla-status-mode-line-process-edit-flag tla-mode-line-process-status)) + (force-mode-line-update)) + + +;; ---------------------------------------------------------------------------- +;; Common used functions for many xtla modes +;; ---------------------------------------------------------------------------- +(defun tla-kill-all-buffers () + "Kill all xtla buffers. +These buffers match the regexp \"\\*tla-.+\\*\"." + (interactive) + (mapcar '(lambda (buf) + (when (string-match "\\*tla-.+\\*" (buffer-name buf)) + (kill-buffer buf))) (buffer-list))) + +(defun tla-buffer-quit () + "Kill the current buffer." + (interactive) + (kill-buffer (current-buffer))) + +(defun tla-edit-=tagging-method () + "Edit the {arch}/=tagging-method file." + (interactive) + (find-file (concat (tla-tree-root) "/{arch}/=tagging-method"))) + +(defun tla-ewoc-delete (cookie elem) + "Remove element ELEM from COOKIE" + (ewoc-filter cookie + '(lambda (x) (not (eq x (ewoc-data elem)))))) + +(defun tla-generic-refresh () + "Calls the function specified by `tla-buffer-refresh-function'" + (interactive) + (funcall tla-buffer-refresh-function)) + +(defun tla--get-info-at-point () + "Get the version information that point is on." + (when (fboundp tla-get-revision-info-at-point-function) + (funcall tla-get-revision-info-at-point-function))) + +(defvar tla-window-config nil + "Used for inter-function communication.") + +(defun tla--ediff-buffers (bufferA bufferB) + "Wrapper around `ediff-buffers'" + (let ((tla-window-config (current-window-configuration))) + (ediff-buffers bufferA bufferB + '(tla-ediff-startup-hook) 'tla-ediff))) + +;; should replace: tla-read-archive-category-name +(defun tla--complete-category (archive &optional prompt) + (tla-categories-build-archive-tree archive) + (completing-read + (or prompt (concat "category for " archive ": ")) + (cddr (tla-archive-tree-get-archive archive)) + nil nil nil + 'tla-read-archive-category-history)) + +(defun tla--insert-right-justified (string count &optional face) + "Inserts STRING preceded by spaces so that the line ends exaclty at +COUNT characters (or after if STRING is too long." + (insert-char ?\ (max 0 (- count (length string)))) + (insert (if face (tla-add-face string face) string)) + ) + +;; should replace: tla-read-archive-category-branch-name +(defun tla--complete-branch (archive category &optional prompt) + (tla-branches-build-archive-tree archive category) + (let ((branch (completing-read + (or prompt (concat "branch for " archive "/" category ": ")) + (cdr (tla-archive-tree-get-category archive category)) + nil nil nil + 'tla-read-archive-category-branch-history))) + (if (string= branch "") + nil + branch))) + +;; should replace: tla-read-archive-category-branch-version-name +(defun tla--complete-version (archive category branch &optional prompt) + (tla-versions-build-archive-tree archive category branch) + (let ((version (completing-read + (or prompt (concat "version for " (tla-fully-qualified-revision + archive category branch) ": ")) + (cdr (tla-archive-tree-get-branch archive category branch)) + nil nil nil + 'tla-read-archive-category-branch-version-history))) + (if (string= version "") + nil + version))) + +;; should replace: tla-read-archive-category-branch-version-revision-name +(defun tla--complete-revision (archive category branch version &optional prompt) + (tla-revisions-build-archive-tree archive category branch version) + (let ((revision (completing-read + (or prompt (concat "revision for " (tla-fully-qualified-revision + archive category branch version) ": ")) + (cdr (tla-archive-tree-get-version archive category branch version)) + nil nil nil + 'tla-read-archive-category-branch-version-revision-history))) + (if (string= revision "") + nil + revision))) + +(defun tla--get-archive (rev) + "Get the archive part of a fully qualified revision" + (if rev + (nth 0 (tla-split-revision-name (cadr rev))) + (car (tla-read-archive-name)))) + +(defun tla--get-category (rev) + "Get the archive/category part of a fully qualified revision" + (let* ((revs (tla-split-revision-name rev)) + (archive (tla-archive-name revs)) + (category (and archive + (or (tla-category-name revs) + (tla--complete-category archive))))) + (tla-fully-qualified-revision archive category))) + +(defun tla--get-branch (rev) + "Get the archive/category-branch part of a fully qualified revision" + (let* ((revs (tla-split-revision-name rev)) + (archive (tla-archive-name revs)) + (category (and archive + (or (tla-category-name revs) + (tla--complete-category archive)))) + (branch (and category + (or (tla-branch-name revs) + (tla--complete-branch archive category))))) + (tla-fully-qualified-revision archive category branch))) + +(defun tla--get-version (rev) + "Get the archive/category-branch-version part of a fully qualified revision" + (let* ((revs (tla-split-revision-name rev)) + (archive (tla-archive-name revs)) + (category (and archive + (or (tla-category-name revs) + (tla--complete-category archive)))) + (branch (and category + (or (tla-branch-name revs) + (tla--complete-branch archive category)))) + (version (and branch + (or (tla-version-name revs) + (tla--complete-version archive category branch))))) + (tla-fully-qualified-revision archive category branch version))) + +(defun tla--get-revision (rev) + "Get the archive/category-branch-version-revision part of a fully qualified revision" + (let* ((revs (tla-split-revision-name rev)) + (archive (tla-archive-name revs)) + (category (and archive + (or (tla-category-name revs) + (tla--complete-category archive)))) + (branch (and category + (or (tla-branch-name revs) + (tla--complete-branch archive category)))) + (version (and branch + (or (tla-version-name revs) + (tla--complete-version archive category branch)))) + (revision (and version + (or (tla-revision-name revs) + (tla--complete-revision archive category branch version))))) + (tla-fully-qualified-revision archive category branch version revision))) + +(defun tla-tree-root (&optional location) + "Returns the tree root for LOCATION, nil if not in a local tree. +Computation is done from withing Emacs, by looking at an {arch} +directory in a parent buffer of LOCATION. This is therefore very +fast." + (let ((pwd (or location default-directory))) + (while (not (or (string= pwd "/") + (file-exists-p (concat pwd "/{arch}")))) + (setq pwd (expand-file-name (concat pwd "/..")))) + (if (file-exists-p (concat pwd "/{arch}")) + (expand-file-name + (replace-regexp-in-string "/$" "" pwd)) + nil))) + +(defun tla-save-some-buffers (&optional tree) + "Saves all buffers visiting a file in TREE" + (let ((ok t) + (tree (or (tla-tree-root tree) + tree))) + (unless tree + (error "Not in a project tree.")) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (buffer-modified-p) + (let ((file (buffer-file-name))) + (when file + (let ((root (tla-tree-root (file-name-directory file))) + (tree-exp (expand-file-name tree))) + (when (and (string= root tree-exp) + ;; buffer is modified and in the tree TREE. + (or tla-do-not-prompt-for-save + (y-or-n-p (concat "Save buffer " + (buffer-name) + "? ")) + (setq ok nil))) + (save-buffer)))))))) + ok)) + +(defun tla-revert-some-buffers (&optional tree) + "Reverts all buffers visiting a file in TREE that aren't modified. +To be ran after an update or a merge." + (let ((tree (tla-tree-root tree))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (not (buffer-modified-p)) + (let ((file (buffer-file-name))) + (when file + (let ((root (tla-tree-root (file-name-directory file))) + (tree-exp (expand-file-name tree))) + (when (and (string= root tree-exp) + ;; buffer is modified and in the tree TREE. + tla-automatically-revert-buffers) + ;; TODO + ;; what should we do if file is not existed? >> Matthieu + (if (file-exists-p file) + (revert-buffer t t))))))))))) + + +(defun tla-switch-to-buffer (buffer) + "Allow customizable buffer switching." + (cond ((eq tla-switch-to-buffer-mode 'pop-to-buffer) + (pop-to-buffer buffer)) + ((eq tla-switch-to-buffer-mode 'single-window) + (switch-to-buffer buffer)) + ;; TODO : dedicated frame. + (t + (error "Switch mode %s not implemented" tla-switch-to-buffer-mode)))) + +;; ---------------------------------------------------------------------------- +;; tla help system for commands that get input from the user via the minibuffer +;; ---------------------------------------------------------------------------- + +;; When the user is asked for input in the minibuffer, a help for the +;; command will be shown, if the user hits f1 +;; This functionality is not only for xtla commands available +;; it is available for all emacs commands +;; to check: we should use some other binding for this, perhaps f1 C-m + +;; GENERIC: This functionality should be in emacs itself. >> Masatake + +(defun tla-display-command-help (command &optional current-prompt) + (save-excursion + (other-window -1) + (let ((cmd-help (when (fboundp command) + (documentation command)))) + (with-current-buffer (get-buffer-create "*tla-command-help*") + (delete-region (point-min) (point-max)) + (insert (if cmd-help + (format "Help for %S:\n%s" command cmd-help) + (format "No help available for %S" command))))) + (Electric-pop-up-window "*tla-command-help*") + (resize-temp-buffer-window) + (other-window 1))) + +(defvar tla-command-stack nil) +(defun tla-minibuffer-setup () + (push this-command tla-command-stack)) + +(defun tla-minibuffer-exit () + (pop tla-command-stack)) + +(defun tla-show-command-help () + (interactive) + (tla-display-command-help (car tla-command-stack) + (minibuffer-prompt))) + +(when tla-install-command-help-system + (define-key minibuffer-local-map [f1] 'tla-show-command-help) + (define-key minibuffer-local-completion-map [f1] 'tla-show-command-help) + (define-key minibuffer-local-must-match-map [f1] 'tla-show-command-help) + (add-hook 'minibuffer-setup-hook 'tla-minibuffer-setup) + (add-hook 'minibuffer-exit-hook 'tla-minibuffer-exit)) + +;; ---------------------------------------------------------------------------- +;; Top level tla commands +;; ---------------------------------------------------------------------------- +(defvar tla-make-log-function nil + "function used to create the log buffer. If nil, call tla make-log +and open the log file") + +(defun tla-make-log-tla () + (interactive) + (if tla-make-log-function + (funcall tla-make-log-function) + (tla-run-arch nil t 'make-log "make-log") + (let ((output (tla-get-process-output))) + (when (string= output "") + (error "Can't create log file. Probably not in a project tree")) + output))) + +(defun tla-make-log () + (interactive) + (let* ((version (tla-tree-version-list)) + (file (concat (tla-tree-root) "/++log." + (tla-category-name version) "--" + (tla-branch-name version) "--" + (tla-version-name version) "--" + (tla-archive-name version)))) + (if (file-exists-p file) + (progn (find-file-noselect file) file) + (if tla-make-log-function + (funcall tla-make-log-function) + (tla-run-arch nil t 'make-log "make-log") + (let ((output (tla-get-process-output))) + (when (string= output "") + (error "Can't create log file. Probably not in a project tree")) + output))))) + + +(defun tla-pop-to-inventory () + (interactive) + (tla-inventory nil t)) + +(defvar tla-inventory-cookie nil) +(defvar tla-inventory-list nil + "Full list for the inventory.") + +(defconst tla-inventory-file-types-manipulators + '((?S tla-inventory-display-source + tla-inventory-toggle-source ?s "source") + (?P tla-inventory-display-precious + tla-inventory-toggle-precious ?p "precious") + (?J tla-inventory-display-junk + tla-inventory-toggle-junk ?j "junk") + (?T tla-inventory-display-tree + tla-inventory-toggle-tree ?t "tree root") + (?U tla-inventory-display-unrecognized + tla-inventory-toggle-unrecognized ?u "unrecognized")) + "List of possible file types in inventory") + +(defun tla-inventory-goto-file (file) + "Put cursor on FILE. nil return means the file hasn't been found" + (goto-char (point-min)) + (let ((current (ewoc-locate tla-inventory-cookie))) + (while (and current (not (string= (caddr (ewoc-data current)) + file))) + (setq current (ewoc-next tla-inventory-cookie current))) + (when current (tla-inventory-cursor-goto current)) + current)) + + +(defun tla-inventory-make-toggle-fn-and-var (variable function) + "Defines the variable and the toggle function for type TYPE." + (eval `(defvar ,variable t)) + (eval `(defun ,function () + (interactive) + (setq ,variable (not ,variable)) + (tla-inventory-redisplay)))) + + + +(dolist (type-arg tla-inventory-file-types-manipulators) + (tla-inventory-make-toggle-fn-and-var (cadr type-arg) (caddr type-arg))) + +(defun tla-inventory-redisplay () + (let* ((elem (ewoc-locate tla-inventory-cookie)) + (file (when elem (caddr (ewoc-data elem)))) + (pos (point))) + (tla-inventory-display) + (or (and file + (tla-inventory-goto-file file)) + (goto-char pos)) + (tla-inventory-cursor-goto (ewoc-locate tla-inventory-cookie)))) + + +(defun tla-inventory-set-toggle-variables (new-value) + "Set all tla-inventory-display-* variables. +If NEW-VALUE is 'toggle set the values to (not tla-inventory-display-* +Otherwise set it to NEW-VALUE." + (dolist (type-arg tla-inventory-file-types-manipulators) + (eval `(setq ,(cadr type-arg) + (if (eq new-value 'toggle) + (not ,(cadr type-arg)) + new-value))))) + +(defun tla-inventory-set-all-toggle-variables () + (interactive) + (tla-inventory-set-toggle-variables t) + (tla-inventory-redisplay)) + +(defun tla-inventory-reset-all-toggle-variables () + (interactive) + (tla-inventory-set-toggle-variables nil) + (tla-inventory-redisplay)) + +(defun tla-inventory-toggle-all-toggle-variables () + (interactive) + (tla-inventory-set-toggle-variables 'toggle) + (tla-inventory-redisplay)) + + +;;;###autoload +(defun tla-inventory (&optional directory arg) + "Show a tla inventory at DIRECTORY. +When called with a prefix arg, pop to the inventory buffer. +DIRECTORY defaults to the current one when within an arch managed tree, +unless you gave two prefix args." + (interactive (list (let ((tree-root (tla-tree-root))) + (if (or (string= "" tree-root) + (and current-prefix-arg + (> (car current-prefix-arg) 4))) + (read-directory-name "TLA Inventory (directory): " + nil nil t) + default-directory)) + current-prefix-arg)) + ;; (tla-run-arch nil t 'inventory "inventory" "--kind" "--ids") + (let ((directory (or directory default-directory))) + (if arg + (pop-to-buffer "*tla-inventory*") + (switch-to-buffer "*tla-inventory*")) + (cd directory)) + (tla-inventory-mode) + (set (make-local-variable 'tla-inventory-list) nil) + (tla-run-arch nil t 'inventory "inventory" "--both") + (save-excursion + (let ((list (split-string (tla-get-process-output) "\n"))) + (mapc + (lambda (item) + (when (string-match "\\([A-Z]\\)\\([\\? ]\\) \\(.*\\)" item) + (tla-inventory-insert-item (string-to-char (match-string 1 item)) + (string= (match-string 2 item) "?") + (match-string 3 item)))) + list))) + (setq tla-inventory-list (reverse tla-inventory-list)) + (tla-inventory-display) + (goto-char (point-min)) + ) + +(defun tla-inventory-insert-item (type question file) + "Adds the file FILE of type TYPE (a char) to the inventory list. +Non-nil QUESTION means the file has no ID yet." + (setq tla-inventory-list + (cons (list type question file) + tla-inventory-list))) + +(defun tla-inventory-display () + (interactive) + (let (buffer-read-only) + (erase-buffer) + (set (make-local-variable 'tla-inventory-cookie) + (ewoc-create 'tla-inventory-printer)) + (tla-inventory-insert-headers) + (dolist (elem tla-inventory-list) + (let ((type (car elem))) + (if (eval (cadr (assoc type + tla-inventory-file-types-manipulators))) + (ewoc-enter-last tla-inventory-cookie elem))))) + (goto-char (point-min))) + +(defun tla-inventory-printer (elem) + (let ((type (car elem)) + (question (cadr elem)) + (file (caddr elem))) + (insert (format "%s%c%s %s" + (if (member file tla-buffer-marked-file-list) + " * " " ") + type (if question "?" " ") file)))) + +(defun tla-inventory-mark-file () + (interactive) + (let ((current (ewoc-locate tla-inventory-cookie)) + (file (tla--get-file-info-at-point))) + (add-to-list 'tla-buffer-marked-file-list file) + (ewoc-refresh tla-inventory-cookie) + (tla-inventory-cursor-goto (or (ewoc-next tla-inventory-cookie + current) + current)))) + +(defun tla-inventory-unmark-file () + (interactive) + (let ((current (ewoc-locate tla-inventory-cookie)) + (file (tla--get-file-info-at-point))) + (setq tla-buffer-marked-file-list + (delete file tla-buffer-marked-file-list)) + (ewoc-refresh tla-inventory-cookie) + (tla-inventory-cursor-goto (or (ewoc-next tla-inventory-cookie + current) + current)))) + +(defun tla-inventory-unmark-all () + (interactive) + (let ((current (ewoc-locate tla-inventory-cookie))) + (setq tla-buffer-marked-file-list nil) + (ewoc-refresh tla-inventory-cookie) + (tla-inventory-cursor-goto current))) + +(defvar tla-get-file-info-at-point-function nil + "Function used to get the file at point, anywhere") + +(defun tla--get-file-info-at-point () + (funcall tla-get-file-info-at-point-function)) + +(defun tla-inventory-get-file-info-at-point () + (caddr (ewoc-data (ewoc-locate tla-inventory-cookie)))) + +(defun tla-inventory-insert-headers () + (ewoc-set-hf tla-inventory-cookie + (tla-add-face (format "tla inventory for %s\n" default-directory) + 'tla-archive-name) + "\nend.")) + +(defvar tla-buffer-source-buffer nil + "Buffer from where a command was called") + +;;;###autoload +(defun tla-edit-log (&optional insert-changelog source-buffer) + "Edit the tla log file. +With an optional prefix argument, insert the last group of entries from the +ChangeLog file. SOURCE-BUFFER, if non-nil, is the buffer from which +the function was called. It is used to get the list of marked files, +and potentially run a selected file commit." + (interactive "P") + (setq tla-pre-commit-window-configuration (current-window-configuration)) + (when (get-buffer tla-process-buffer) + (kill-buffer tla-process-buffer)) + (setq tla-log-edit-file-name (tla-make-log)) + (find-file tla-log-edit-file-name) + (when insert-changelog + (goto-char (point-max)) + (let ((buf (find-file-noselect (find-change-log)))) + (insert-buffer buf)) + (when (re-search-forward "^2" nil t) + (delete-region (line-beginning-position) + (line-beginning-position 3))) + (when (re-search-forward "^2" nil t) + (delete-region (line-beginning-position) (point-max))) + (goto-char (point-min))) + (tla-log-edit-mode) + (set (make-local-variable 'tla-buffer-source-buffer) + source-buffer) + (end-of-line)) + +;;;###autoload +(defun tla-add-log-entry () + "Add new tla log ChangeLog style entry." + (interactive) + (save-restriction + (tla-add-log-entry-internal))) + +(defun tla-add-log-entry-internal () + ;; This is mostly copied from add-log.el. Perhaps it would be better to + ;; split add-change-log-entry into several functions and then use them, but + ;; that wouldn't work with older versions of Emacs. + (require 'add-log) + (let* ((defun (add-log-current-defun)) + (buf-file-name (if (and (boundp 'add-log-buffer-file-name-function) + add-log-buffer-file-name-function) + (funcall add-log-buffer-file-name-function) + buffer-file-name)) + (buffer-file (if buf-file-name (expand-file-name buf-file-name))) + (file-name (tla-make-log)) + ;; Set ENTRY to the file name to use in the new entry. + (entry (if (functionp 'add-log-file-name) + (add-log-file-name buffer-file file-name) + (file-relative-name buffer-file (tla-tree-root)))) + beg + bound + narrowing) + (tla-edit-log) + (undo-boundary) + (goto-char (point-min)) + (when (re-search-forward "^Patches applied:" nil t) + (narrow-to-region (point-min) (match-beginning 0)) + (setq narrowing t) + (goto-char (point-min))) + (re-search-forward "\n\n\\|\\'") + (setq beg (point)) + (setq bound + (progn + (if (looking-at "\n*[^\n* \t]") + (skip-chars-forward "\n") + (if (and (boundp 'add-log-keep-changes-together) + add-log-keep-changes-together) + (goto-char (point-max)) + (forward-paragraph))) ; paragraph delimits entries for file + (point))) + (goto-char beg) + (forward-line -1) + ;; Now insert the new line for this entry. + (cond ((re-search-forward "^\\s *\\*\\s *$" bound t) + ;; Put this file name into the existing empty entry. + (if entry + (insert entry))) + ((let (case-fold-search) + (re-search-forward + (concat (regexp-quote (concat "* " entry)) + ;; Don't accept `foo.bar' when + ;; looking for `foo': + "\\(\\s \\|[(),:]\\)") + bound t)) + ;; Add to the existing entry for the same file. + (re-search-forward "^\\s *$\\|^\\s \\*") + (goto-char (match-beginning 0)) + ;; Delete excess empty lines; make just 2. + (while (and (not (eobp)) (looking-at "^\\s *$")) + (delete-region (point) (line-beginning-position 2))) + (insert-char ?\n 2) + (forward-line -2) + (indent-relative-maybe)) + (t + ;; Make a new entry. + (if tla-log-insert-last + (progn + (goto-char (point-max)) + (re-search-backward "^.") + (end-of-line) + (insert "\n\n* ") + ) + (forward-line 1) + (while (looking-at "\\sW") + (forward-line 1)) + (while (and (not (eobp)) (looking-at "^\\s *$")) + (delete-region (point) (line-beginning-position 2))) + (insert-char ?\n 3) + (forward-line -2) + (indent-to left-margin) + (insert "* ")) + (if entry (insert entry)))) + (if narrowing (widen)) + ;; Now insert the function name, if we have one. + ;; Point is at the entry for this file, + ;; either at the end of the line or at the first blank line. + (if defun + (progn + ;; Make it easy to get rid of the function name. + (undo-boundary) + (unless (save-excursion + (beginning-of-line 1) + (looking-at "\\s *$")) + (insert ?\ )) + ;; See if the prev function name has a message yet or not + ;; If not, merge the two entries. + (let ((pos (point-marker))) + (if (and (skip-syntax-backward " ") + (skip-chars-backward "):") + (looking-at "):") + (progn (delete-region (+ 1 (point)) (+ 2 (point))) t) + (> fill-column (+ (current-column) (length defun) 3))) + (progn (delete-region (point) pos) + (insert ", ")) + (goto-char pos) + (insert "(")) + (set-marker pos nil)) + (insert defun "): ")) + ;; No function name, so put in a colon unless we have just a star. + (unless (save-excursion + (beginning-of-line 1) + (looking-at "\\s *\\(\\*\\s *\\)?$")) + (insert ": "))))) + +;;;###autoload +(defun tla-changes (&optional arg) + "Run tla changes. +When called without a prefix argument: show the detailed diffs also. +When called with a prefix argument: do not show detailed diffs" + (interactive "P") + (tla-save-some-buffers) + (let () + (if arg + (tla-run-arch t t 'changes "changes") + (tla-run-arch t t 'changes "changes" "--diffs")))) + +(defun tla-changes-printer (elem) + "ewoc pretty-printer" + (insert (if (member (car elem) tla-buffer-marked-file-list) "* " " ") + (cadr elem) (caddr elem) " " (car elem)) + ) + +(defvar tla-changes-cookie nil + "ewoc cookie for the changes buffer.") + +(defconst tla-verbose-format-spec + '(("added files" "A" " ") + ("modified files" "M" " ")) + "Internal variable used to parse the output of tla show-changeset" + ) + +(defun tla-show-changes-buffer (&optional verbose-format) + "Show the *tla-changes* buffer built from the *tla-process* buffer. +If VERBOSE-FORMAT is non-nil, the format of the *tla-process* buffer +should be the one of tla show-changeset." + (tla-switch-to-buffer "*tla-changes*") + (let (buffer-read-only) + (erase-buffer) + (tla-changes-mode) + (with-current-buffer tla-process-buffer + (let ((root (tla-tree-root)) + (header "")) + (if verbose-format + (progn + (goto-char (point-min)) + (while (re-search-forward + (concat "^\\* \\(" (regexp-opt + (mapcar 'car tla-verbose-format-spec)) + "\\)\n") + nil t) + (let* ((elem (assoc (match-string 1) + tla-verbose-format-spec)) + (modif (cadr elem)) + (dir (caddr elem)) + file) + (if (string= modif "M") + (while (re-search-forward "^--- orig/\\(.*\\)$" + nil t) + (let ((file (match-string 1))) + (with-current-buffer "*tla-changes*" + (ewoc-enter-last tla-changes-cookie + (list file modif dir))))) + (while (looking-at "^$") (forward-line 1)) + (while (looking-at + "^ +\\([^ ].*\\)$") + (message "while ...modif=%s dir=%s" modif dir) + (let ((file (match-string 1))) + (message "file=%s modif=%s dir=%s" file modif dir) + (with-current-buffer "*tla-changes*" + (ewoc-enter-last tla-changes-cookie + (list file modif dir))) + (forward-line 1))))))) + (setq header (buffer-substring-no-properties + (goto-char (point-min)) + (progn (re-search-forward "^[^*]" nil t) + (beginning-of-line) + (point)))) + (while (looking-at "^\\(.\\)\\([ /]\\) +\\(.*\\)$") + (let ((file (match-string 3)) + (modif (match-string 1)) + (dir (match-string 2))) + (with-current-buffer "*tla-changes*" + (ewoc-enter-last tla-changes-cookie + (list file modif dir)))) + (forward-line 1))) + (let ((footer (buffer-substring-no-properties + (point) (point-max)))) + (with-current-buffer "*tla-changes*" + (ewoc-set-hf tla-changes-cookie header footer) + (cd root)))) + )) + (toggle-read-only 1) + (when (or (and (boundp 'global-font-lock-mode) + global-font-lock-mode) + (and (boundp 'font-lock-maximum-decoration) + font-lock-maximum-decoration)) + (font-lock-fontify-buffer)) + (if (ewoc-nth tla-changes-cookie 0) + (goto-char (ewoc-location (ewoc-nth tla-changes-cookie 0))))) + + +;;;###autoload +(defun tla-delta (from to) + "Runs tla delta FROM TO" + (interactive (list + (apply 'tla-fully-qualified-revision + (tla-read-archive-category-branch-version-revision-name)) + (apply 'tla-fully-qualified-revision + (tla-read-archive-category-branch-version-revision-name)) + )) + (tla-run-arch t t 'delta "delta" "--diffs" from to)) + +;;;###autoload +(defun tla-get-changeset (revision justshow &optional destination + without-diff) + "When JUSTSHOW is non-nil, just show the diff. Otherwise, store +changeset in DESTINATION" + (interactive "sRevision to view: \np") + (let ((dest (or destination + (make-temp-name "/tmp/tla-changeset")))) + (tla-run-arch nil t 'get-changeset "get-changeset" revision + dest) + (when justshow + (if without-diff + (tla-run-arch nil t 'show-changeset "show-changeset" dest) + (tla-run-arch nil t 'show-changeset "show-changeset" + "--diffs" dest)) + (tla-show-changes-buffer t) + (call-process "rm" nil nil nil "-rf" + dest)) + ) + ) + +;;;###autoload +(defun tla-file-ediff-revisions (file &optional revision1 revision2) + "View changes between REVISION1 and REVISION2 in file FILE using +ediff." + (interactive (let ((version-list (tla-tree-version-list))) + (list (buffer-file-name) + (apply 'tla-fully-qualified-revision + (append version-list + (list + (apply 'tla--complete-revision + version-list)))) + (apply 'tla-fully-qualified-revision + (append version-list + (list + (apply 'tla--complete-revision + version-list))))))) + (tla--ediff-buffers + (tla-file-get-original file revision1) + (tla-file-get-original file revision2))) + +;;;###autoload +(defun tla-file-diff (file &optional revision) + "Run tla file-diff on file FILE. In interactive mode, the file is +the current buffer's file." + (interactive (list (buffer-file-name))) + (let () + (if revision + (tla-run-arch nil t 'file-diffs "file-diffs" file revision) + (tla-run-arch nil t 'file-diffs "file-diffs" file)) + (if (with-current-buffer tla-process-buffer + (= (point-max) (point-min))) + (message "No changes in this arch working copy") + (tla-show-process-buffer-internal t "*tla-file-diffs*" + 'diff-mode) + (pop-to-buffer "*tla-file-diffs*")))) + +(defvar tla-mine-string "TREE") +(defvar tla-his-string "MERGE-SOURCE") + +;;;###autoload +(defun tla-view-conflicts (buffer) + "*** WARNING : Use this function if you like, but M-x smerge-mode +RET is actually better for the same task **** + +Graphical view of conflicts after tla star-merge --three-way. The +buffer given as an argument must be the content of a file with +conflicts markers like. + + <<<<<<< TREE + my text + ======= + his text + >>>>>>> MERGE-SOURCE + +Priority is given to your file by default. (This means all conflicts +will be rejected if you do nothing). +" + (interactive (list (find-file (read-file-name "View conflicts in: ")))) + (let ((mine-buffer buffer) + (his-buffer (get-buffer-create "*tla-his*"))) + (with-current-buffer his-buffer + (erase-buffer) + (insert-buffer mine-buffer) + (goto-char (point-min)) + (while (re-search-forward (concat "^<<<<<<< " + (regexp-quote tla-mine-string) "$") + nil t) + (beginning-of-line) + (delete-region (point) (progn + (re-search-forward "^=======\n"))) + (re-search-forward + (concat "^>>>>>>> " + (regexp-quote tla-his-string) "$")) + (beginning-of-line) + (delete-region (point) (1+ (line-end-position))) + ) + ) + (with-current-buffer mine-buffer + (goto-char (point-min)) + (while (re-search-forward (concat "^<<<<<<< " + (regexp-quote tla-mine-string) "$") + nil t) + (beginning-of-line) + (delete-region (point) (1+ (line-end-position))) + (re-search-forward "^=======$") + (beginning-of-line) + (delete-region (point) (progn + (re-search-forward + (concat "^>>>>>>> " + (regexp-quote tla-his-string) "\n")))) + )) + (tla--ediff-buffers mine-buffer his-buffer) + )) + +(defun tla-file-get-original-file (file &optional revision) + "Get the last-committed version of FILE. Returns (original-file +unmodified temporary). unmodified is non-nil if the file wasn't +modified since last commit. temporary is non-nil when the file is +temporary and should be deleted." + (let* ((default-directory (or (tla-tree-root file) + (error "not in a project tree"))) + (original (progn (if revision + (tla-run-arch nil t 'file-find + "file-find" file revision) + (tla-run-arch nil t 'file-find + "file-find" file)) + (with-current-buffer tla-process-buffer + (goto-char (point-min)) + (re-search-forward "^[^*]") + (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))))) + (original-to-be-removed nil) + file-unmodified-p) + (unless (file-exists-p original) + ;; Probably tla is ran remotely or whatever. Well, get the + ;; file using the old good tla file-diff | patch -R -o ... + (setq original (make-temp-name "/tmp/tla-ediff") + original-to-be-removed t) + (if revision + (tla-run-arch nil t 'file-diffs "file-diffs" file revision) + (tla-run-arch nil t 'file-diffs "file-diffs" file)) + (with-current-buffer tla-process-buffer + (if (= (point-min) (point-max)) + (setq file-unmodified-p t)) + (call-process-region (point-min) (point-max) + tla-patch-executable + nil nil nil + "-R" "-o" original file))) + (list original file-unmodified-p original-to-be-removed))) + +(defun tla-file-revert (file &optional revision) + "Reverts the file FILE to the last committed version. Warning: You +use version control to keep backups of your files. This function will +by definition not keep any backup in the archive. + +Most of the time, you should not use this function. Call +`tla-file-ediff' instead, and undo the changes one by one with the key +`b', then save your buffer. + +As a last chance, tla-file-revert keeps a backup of the last-saved in +~ backup file." + (interactive (list (progn (when (and (buffer-modified-p) + (y-or-n-p (format "Save buffer %s? " + (buffer-name + (current-buffer))))) + (save-buffer)) + (buffer-file-name)))) + (copy-file file (car (find-backup-file-name file)) t) + (let* ((file-unmo-temp (tla-file-get-original-file file revision)) + (original (car file-unmo-temp)) + (unmodified (cadr file-unmo-temp))) + (when unmodified + (error "File not modified")) + (unless (yes-or-no-p (format "Are you sure you want to revert %s? " + file)) + (error "Not reverting file")) + (copy-file original file t) + (let ((buf (get-file-buffer file))) + (when buf (with-current-buffer buf (revert-buffer)))))) + +;;;###autoload +(defun tla-file-ediff (file &optional revision) + "Interactive view of differences since last commit (or REVISION if +specified) using ediff." + (interactive (list (progn (when (and (buffer-modified-p) + (y-or-n-p (format "Save buffer %s? " + (buffer-name + (current-buffer))))) + (save-buffer)) + (buffer-file-name)))) + (tla--ediff-buffers (or (get-file-buffer file) + (find-file file)) + (tla-file-get-original file revision))) + +;;;###autoload +(defun tla-file-view-original (file &optional revision) + "Gets the last-committed version of FILE in a buffer." + (interactive (list (buffer-file-name))) + (pop-to-buffer (tla-file-get-original file revision))) + +(defun tla-file-get-original (file &optional revision) + "Gets the last committed version of file in a buffer. Returned value +is the buffer" + (let* ((modified-buf (or (get-file-buffer file) + (find-file-noselect file))) + (file-unmo-temp (tla-file-get-original-file file revision)) + (original (car file-unmo-temp)) + (unmodified (cadr file-unmo-temp)) + (original-to-be-removed (caddr file-unmo-temp))) + (when unmodified + (error "No modification in this file")) + (let ((buffer-orig (get-buffer-create + (concat (file-name-nondirectory file) + "<" (or revision + "original") ">")))) + (with-current-buffer buffer-orig + (erase-buffer) + (insert-file-contents original) + (when original-to-be-removed + (delete-file original)) + (when (string= (with-current-buffer modified-buf + (buffer-substring-no-properties (point-min) + (point-max))) + (buffer-substring-no-properties (point-min) + (point-max))) + (error "No modification in this file"))) + buffer-orig))) + +(defun tla-ediff-startup-hook () + ;; ediff-after-quit-hook-internal is local to an ediff session. + (add-hook 'ediff-after-quit-hook-internal + `(lambda () + (set-window-configuration + ,tla-window-config)) + nil 'local)) + +;;;###autoload +(defun tla-commit () + "Runs tla commit. +Returns the exit status of tla" + (interactive) + (or (tla-save-some-buffers) + (y-or-n-p + "Commit with unsaved changes is a bad idea. Continue anyway? ") + (error "Not committing")) + (let* ((file-list (and (buffer-live-p tla-buffer-source-buffer) + (with-current-buffer tla-buffer-source-buffer + tla-buffer-marked-file-list))) + arglist) + (when tla-strict-commits (add-to-list 'arglist "--strict")) + (when file-list (setq arglist (append arglist (cons "--" file-list)))) + (let ((status (apply 'tla-run-arch nil t 'commit "commit" arglist))) + (if (equal status 0) + (tla-show-process-buffer-internal t) + (pop-to-buffer tla-error-buffer)) + status))) + +;;;###autoload +(defun tla-rm (file) + "Calls tla rm on file FILE. Prompts for confirmation before" + (when (yes-or-no-p (format "Delete file %s? " file)) + (tla-run-arch nil t 'rm "rm" file))) + +(defun tla-pristines () + (interactive) + (tla-run-arch nil t 'pristines "pristines") + (tla-show-process-buffer-internal t)) + +;;;###autoload +(defun tla-changelog () + (interactive) + (tla-run-arch nil t 'changelog "changelog") + (tla-show-process-buffer-internal t "*tla-changelog*" 'tla-changelog-mode)) + +(defvar tla-logs-flag-list '("--summary" "--date" "--creator")) + +;;;###autoload +(defun tla-logs () + "Run tla logs" + (interactive) + (tla-run-arch nil t 'logs (append (list "logs") tla-logs-flag-list)) + (tla-show-process-buffer-internal t "*tla-logs*" 'tla-logs-mode)) + +;;;###autoload +(defun tla-tree-lint () + "Audit an arch source tree." + (interactive) + (let ((no-warnings)) + (when (get-buffer tla-process-buffer) + (kill-buffer tla-process-buffer)) + (tla-run-arch nil t 'tree-lint "tree-lint") + (save-excursion + (set-buffer tla-process-buffer) + (setq no-warnings (= (- (point-max) (point-min)) 0))) + (if no-warnings + (message "No tree-lint warnings for this arch working copy") + (tla-show-process-buffer-internal t)))) + +(defun tla-tree-version-list-tla () + "Returns the tree version, or nil if not in a project tree" + (tla-run-arch nil t 'tree-version "tree-version") + (with-current-buffer tla-process-buffer + (and + (goto-char (point-min)) + (re-search-forward "\\(.*\\)/\\(.*\\)--\\(.*\\)--\\(.*\\)" nil t) + (list (match-string 1) + (match-string 2) + (match-string 3) + (match-string 4))))) + +(defun tla-tree-version-list () + "Elisp implementation of `tla-tree-version-list-tla'" + (with-temp-buffer + (insert-file-contents (concat (tla-tree-root) + "/{arch}/++default-version")) + (and + (goto-char (point-min)) + (re-search-forward "\\(.*\\)/\\(.*\\)--\\(.*\\)--\\(.*\\)" nil t) + (list (match-string 1) + (match-string 2) + (match-string 3) + (match-string 4))))) + +(defun tla-tree-root-tla () + "Run tla tree-root." + (interactive) + (tla-run-arch nil t 'tree-root "tree-root") + (when (interactive-p) + (message "tla tree-root is: %s" (tla-get-process-output))) + (tla-get-process-output)) + +(defun tla-tree-version (&optional interactive) + (interactive (list t)) + (let ((version + (with-temp-buffer + (insert-file-contents (concat (tla-tree-root) + "/{arch}/++default-version")) + (buffer-substring-no-properties (point-min) + (- (point-max) 1))))) + (if interactive + (message version) + version))) + +;;;###autoload +(defun tla-my-id (&optional arg) + "Run tla my-id. +When called without a prefix argument, just print the my-id from tla. +When called with a prefix argument, ask for a new my-id. + +The my-id should have the following format: + +Your id is recorded in various archives and log messages +as you use arch. It must consist entirely of printable +characters and fit on one line. By convention, it should +have the form of an email address, as in this example: + +Jane Hacker <jane.hacker@gnu.org> +" + (interactive "P") + (let ((result (tla-run-arch nil t 'my-id "my-id")) + (id (tla-get-process-output))) + ;; TODO: check result. + (if arg + (tla-set-my-id-interactive id) + (if (and id (string= "" id)) + (message "Arch my-id has not been given yet. Call `%s' with prefix arguments to set." + this-command) + (when (interactive-p) (message "Arch my-id: %s" id))) + id))) + +(defun tla-set-my-id-interactive (&optional old-id) + (unless old-id (setq old-id "")) + (let ((new-id (read-string "New arch my-id: " + old-id tla-my-id-history old-id))) + (if (not (string= old-id new-id)) + (progn + (message "Setting id to: %s" new-id) + (tla-set-my-id new-id)) + old-id))) + +(defun tla-set-my-id (new-id) + "Set tla's my-id. " + (interactive (list (read-string "New arch my-id: " id tla-my-id-history id) + nil)) + (when (not (string= old-id new-id)) + (message "Setting id to: %s" new-id) + (tla-run-arch nil t 'my-id "my-id" new-id) + new-id)) + +;; +;; Library +;; + +;;;###autoload +(defun tla-my-revision-library (&optional arg) + "Run tla my-revision-library. +When called without a prefix argument, just print the my-revision-library from tla. +When called with a prefix argument, ask for a new my-revision-library. + +my-revision-library specifies a path, where the revision library is stored to +speed up tla. For example ~/tmp/arch-lib. + +You can configure the parameters for the library via tla-library-config." + (interactive "P") + (let ((result (tla-run-arch nil t 'my-revision-library "my-revision-library")) + (rev-lib (tla-get-process-output)) + (dir-attr)) + (if arg + (tla-set-revision-library-interactive rev-lib) + (if (and rev-lib (string= "" rev-lib)) + (message "Arch my-revision-library has not been given yet. Call `%s' with prefix arguments to set." + this-command) + (when (interactive-p) (message "Arch my-revision-library: %s" rev-lib))) + rev-lib))) + +(defun tla-set-revision-library-interactive (&optional old-rev-lib) + (unless old-rev-lib (setq old-rev-lib "")) + (let ((new-rev-lib (expand-file-name (read-directory-name + "New arch revision library: " old-rev-lib)))) + (if (not (string= old-rev-lib new-rev-lib)) + (progn + (message "Setting my-revision-library to: %s" new-rev-lib) + (tla-set-revision-library new-rev-lib)) + old-rev-lib))) + +(defun tla-set-revision-library (new-rev-lib) + (let ((dir-attr (file-attributes new-rev-lib))) + (unless dir-attr + (make-directory new-rev-lib t)) + (tla-run-arch nil t 'my-revision-library "my-revision-library" new-rev-lib) + new-rev-lib)) + +(defun tla-library-config (&optional arg) + "Run tla library-config. +When called without a prefix argument, just print the config. +When called with a prefix argument, let the user change the config." + (interactive "P") + (let ((rev-lib (tla-my-revision-library)) + (config-param)) + (if arg + (progn + (setq config-param (completing-read "tla library config " + (mapcar 'list '("--greedy" "--sparse")) + nil t "--greedy")) + (tla-run-arch nil t 'library-config "library-config" config-param rev-lib)) + (tla-run-arch nil t 'library-config "library-config" rev-lib) + (message (tla-get-process-output))))) + +(defun tla-library-add (archive category branch version revision) + (pop-to-buffer tla-process-buffer) + (tla-run-arch t t 'library-add "library-add" "-A" archive + (tla-name-construct category branch version revision))) + +(defun tla-library-find (archive category branch version revision + &optional silent) + "Run tla library-find. +If the revision is found, return the path for it. Else return nil." + (if (zerop (if silent + (tla-run-arch nil t 'library-find "library-find" "--silent" "-A" archive + (tla-name-construct category branch version + revision)) + (tla-run-arch nil t 'library-find "library-find" "-A" archive + (tla-name-construct category branch version revision)))) + (tla-get-process-output))) + +;; completing-read: tagline, explicit, names, implicit +(defvar tla-id-tagging-method-history nil) +;;;###autoload +(defun tla-id-tagging-method (arg) + "View or change the id-tagging method. +When called without a prefix argument: show the actual tagging method. +When called with a prefix argument: Ask the user for the new tagging method." + (interactive "P") + (let ((tm (progn (tla-run-arch nil t 'id-tagging-method "id-tagging-method") + (tla-get-process-output))) + (new-tagging-method)) + (if arg + (progn + (setq new-tagging-method + (completing-read "New id tagging method: " + (mapcar 'list '("tagline" "explicit" "names" "implicit")) + nil t "tagline" tla-id-tagging-method-history)) + (when (not (string= tm new-tagging-method)) + (message "Setting tagging method to: %s" new-tagging-method) + (tla-run-arch nil t 'id-tagging-method "id-tagging-method" new-tagging-method))) + (message "Arch id tagging method: %s" tm)))) + +;;(defun tla-archive-mirror (&optional from to limit) +;; (tla-run-arch t t 'archive-mirror +;; (append (delq nil (list "archive-mirror" from to limit))))) +(defun tla-archive-mirror (archive &optional category branch version from) + "Synchronize the mirror for the archive ARCHIVE. Limit to +CATEGORY--BRANCH--VERSION. If FROM is provided, mirror from it." + (interactive (tla-read-archive-name)) + (tla-run-arch + t t 'archive-mirror + (append (delq nil (list "archive-mirror" + archive + (let ((name (tla-fully-qualified-revision + nil category branch version))) + (if (string= name "") nil name)) + from))))) + +(defun tla-star-merge (from &optional to-tree) + ;;(message "run tla star-merge %s" from) + (or (tla-save-some-buffers (or to-tree default-directory)) + (y-or-n-p + "Update may delete unsaved changes. Continue anyway? ") + (error "Not updating")) + (pop-to-buffer tla-process-buffer) + (when to-tree (cd to-tree)) + (if tla-three-way-merge + (tla-run-arch t t 'star-merge "star-merge" "--three-way" from) + (tla-run-arch t t 'star-merge "star-merge" from)) + ) + +(defun tla-tag (source-revision tag-version) + "Runs tla tag --setup" + (tla-run-arch nil t 'tag "tag" "--setup" + source-revision tag-version) + (tla-show-process-buffer-internal t)) + +;; +;; Xtla bookmarks +;; + +(defvar tla-bookmarks-loaded nil + "wether tla-bookmarks have been loaded from file") + +(defvar tla-bookmarks-alist nil + "Alist containing xtla bookmarks.") + +(defvar tla-bookmarks-show-details nil + "Wether tla-bookmarks shoudl show bookmark details") + +(defvar tla-bookmarks-cookie nil + "ewoc dll") + +(defvar tla-bookmarks-missing-buffer-list-elem nil + "List of cons (bookmark . local-tree)") + +(defvar tla-bookmarks-missing-buffer-todolist nil + "List of (kind info) which can be + (separator \"label\" bookmark \"local-tree\") + (changes \"local-tree\") + (missing \"local-tree\" \"location\" \"bookmark-name\")") + +(defvar tla-bookmarks-marked-list nil + "list of marked bookmaks") + +(defun tla-bookmarks-load-from-file (&optional force) + (when (or force (not tla-bookmarks-loaded)) + (let ((file (expand-file-name tla-bookmarks-file-name))) + (save-excursion + (unless (file-exists-p file) + (with-temp-buffer + (insert "()") + (write-file file))) + (unless (file-readable-p file) + (error "Xtla bookmark file not readable")) + (with-temp-buffer + (insert-file-contents file) + (setq tla-bookmarks-alist (read (current-buffer)) + tla-bookmarks-loaded t)))))) + +(defun tla-bookmarks-save-to-file () + "Saves `tla-bookmarks-alist' to a file" + (let ((print-quoted t) + (print-readably t) + print-level print-length + (file (expand-file-name tla-bookmarks-file-name))) + (with-temp-buffer + (insert (pp-to-string tla-bookmarks-alist)) + (write-file file)))) + +(defun tla-bookmarks-toggle-details (&optional val) + "toggles the value of `tla-bookmarks-toggle-details'" + (interactive "P") + (let ((current-bookmark (ewoc-locate tla-bookmarks-cookie))) + (setq tla-bookmarks-show-details + (if val + (if (> val 0) t + (if (< val 0) nil + (not tla-bookmarks-show-details))) + (not tla-bookmarks-show-details))) + (ewoc-refresh tla-bookmarks-cookie) + (tla-bookmarks-cursor-goto current-bookmark))) + +(defun tla-bookmarks-printer (element) + "Pretty printer used by ewoc, printing an entry of the bookmark +list" + (insert (if (member element tla-bookmarks-marked-list) " *" " ")) + (tla--insert-right-justified (concat (car element) ": ") 15 + 'tla-bookmark-name) + (insert (tla-add-face (apply 'tla-fully-qualified-revision + (cdr (assoc 'location (cdr element)))) + 'tla-revision-name)) + (when tla-bookmarks-show-details + (newline) + (insert-char ?\ 17) + (insert (cdr (assoc 'timestamp (cdr element)))) + (newline) + (let ((notes (assoc 'notes (cdr element)))) + (when notes + (insert-char ?\ 17) + (insert (cdr notes)) + (newline))) + (let ((partners (assoc 'partners (cdr element)))) + (when partners + (tla--insert-right-justified "partners: " 17) + (insert (cadr partners)) + (dolist (x (cddr partners)) + (insert ",\n") + (insert-char ?\ 17) + (insert x)) + (newline))) + (let ((local-tree (assoc 'local-tree (cdr element)))) + (when local-tree + (tla--insert-right-justified "local trees: " 17) + (insert (cadr local-tree)) + (dolist (x (cddr local-tree)) + (insert ", " x )) + (newline))) + (let ((groups (assoc 'groups (cdr element)))) + (when groups + (tla--insert-right-justified "Groups: " 17) + (insert (cadr groups)) + (dolist (x (cddr groups)) + (insert ", " x )) + (newline))) + ) + ) + +(defvar tla-revision-list-cookie nil + "ewoc cookie for tla-bookmark-missing") + +(defun tla-bookmarks-read-local-tree (bookmark arg) + "Reads a local tree from keyboard for bookmark BOOKMARK, and +possibly add it to the bookmarks. If arg is non-nil, user will be +prompted anyway. Otherwise, just use the default if it exists." + (let* ((local-trees (assoc 'local-tree (cdr bookmark)))) + (cond + ((not local-trees) + (let ((dir (read-directory-name + (format "Local tree for \"%s\": " + (car bookmark))))) + (when (y-or-n-p "Add this tree in your bookmarks? ") + (tla-bookmarks-add-tree bookmark dir)) + dir)) + (arg + ;; multiple local trees. + (let ((dir (completing-read + (format "Local tree for \"%s\": " + (car bookmark)) + (mapcar #'(lambda (x) (cons x nil)) + (cdr local-trees)) + nil nil nil nil (cadr local-trees)))) + (when (and (not (member dir (cdr local-trees))) + (y-or-n-p "Add this tree in your bookmarks? ")) + (tla-bookmarks-add-tree bookmark dir)) + (when (and (not (string= + dir (cadr local-trees))) + (y-or-n-p "Make this the default? ")) + (tla-bookmarks-delete-tree bookmark dir) + (tla-bookmarks-add-tree bookmark dir)) + dir)) + (t (cadr local-trees))))) + +(defun tla-bookmarks-missing (&optional arg) + "Show the missing patches from your partners. +The missing patches are received via tla missing. +Additionaly the local changes in your working copy are also shown." + (interactive "P") + (let ((list (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie)))))) + (set-buffer (get-buffer-create "*tla-bookmarks-missing*")) + (tla-revision-list-mode) + (set (make-local-variable 'tla-buffer-refresh-function) + 'tla-bookmarks-missing-refresh) + (set (make-local-variable + 'tla-bookmarks-missing-buffer-list-elem) + (mapcar + #'(lambda (elem) + (cons + elem + (tla-bookmarks-read-local-tree elem arg))) + list)) + (tla-bookmarks-missing-refresh))) + + +(defun tla-bookmarks-missing-refresh (&optional arg) + (interactive) + (let (buffer-read-only) + (erase-buffer)) + (set (make-local-variable 'tla-revision-list-cookie) + (ewoc-create 'tla-revision-list-printer)) + (set (make-local-variable 'tla-bookmarks-missing-buffer-todolist) + nil) + (dolist (elem tla-bookmarks-missing-buffer-list-elem) + (tla-bookmarks-missing-elem (car elem) arg (cdr elem) t + t)) + (setq tla-bookmarks-missing-buffer-todolist + (reverse tla-bookmarks-missing-buffer-todolist)) + (tla-bookmarks-missing-do-todolist)) + + +(defun tla-bookmarks-missing-elem (data arg local-tree header + &optional changes-too) + "Show missing patches for one element" + (let* ((partners (assoc 'partners (cdr data))) + (location (cdr (assoc 'location (cdr data))))) + (pop-to-buffer "*tla-bookmarks-missing*") + (cd local-tree) + (setq tla-bookmarks-missing-buffer-todolist + (cons `(separator + ,(format "Bookmark %s (%s):" + (car data) + (apply + 'tla-fully-qualified-revision + location)) + bookmark + ,local-tree) + tla-bookmarks-missing-buffer-todolist)) + (when changes-too + (setq tla-bookmarks-missing-buffer-todolist + (cons `(changes ,local-tree) + tla-bookmarks-missing-buffer-todolist))) + (dolist (partner (cons (apply 'tla-fully-qualified-revision + (cdr (assoc 'location (cdr data)))) ; Me + (cdr partners))) ; and my partners + (setq tla-bookmarks-missing-buffer-todolist + (cons `(missing ,local-tree ,partner ,partner) ; todo + ; second should be bookmark + ; name. + tla-bookmarks-missing-buffer-todolist)) + )) + (goto-char (point-min)) + ) + +(defun tla-bookmarks-missing-do-todolist () + (let ((continue t)) + (while (and tla-bookmarks-missing-buffer-todolist continue) + (let ((todo (car tla-bookmarks-missing-buffer-todolist)) + buffer-read-only) + (case (car todo) + (missing + (let* ((bmk (nth 3 todo)) + (text (if bmk (concat "Missing patches for partner " + bmk ":") + (concat "Missing patches for archive " + (nth 2 todo))))) + (ewoc-enter-last tla-revision-list-cookie + (list 'separator (concat + text) + 'partner)) + (setq continue nil)) + (let ((default-directory (cadr todo))) + (tla-run-arch t t 'missing-list "missing" "--full" + "--summary" "--creator" "--date" + (nth 2 todo))) + ) + (separator + (ewoc-enter-last tla-revision-list-cookie + (list 'separator + (cadr todo) + 'bookmark + (cadddr todo)))) + (changes + (setq continue nil) + (let ((default-directory (cadr todo))) + (tla-run-arch t t 'changes-list "changes"))) + )) + (setq tla-bookmarks-missing-buffer-todolist + (cdr tla-bookmarks-missing-buffer-todolist))) + (when (not tla-bookmarks-missing-buffer-todolist) + (ewoc-set-hf tla-revision-list-cookie "" + (concat "\n" (tla-add-face "end." 'tla-separator)))) + )) + +(defun tla-bookmarks-missing-parse-missing () + (let ((cookie tla-revision-list-cookie) + revision date creator summary) + (with-current-buffer tla-process-buffer + (goto-char (point-min)) + (re-search-forward ".*/.*--.*--.*--.*" nil t) + (beginning-of-line) + (while (> (point-max) (point)) + (setq revision (buffer-substring-no-properties + (point) (line-end-position))) + (forward-line 1) + (re-search-forward " +\\(.*[^ ]\\) *\\(.*\\)" (line-end-position)) + (setq date (match-string-no-properties 1)) + (setq creator (match-string-no-properties 2)) + (forward-char 1) + (if (re-search-forward " +" (line-end-position) t) + (progn (setq summary (buffer-substring-no-properties + (point) (line-end-position))) + (forward-line 1)) + (setq summary "")) + (ewoc-enter-last cookie + (list 'entry-patch nil + (tla-split-revision-name revision) + summary creator date)) + )))) + +(defun tla-bookmarks-missing-parse-changes () + (with-current-buffer tla-process-buffer + (let ((changes + (progn (goto-char (point-min)) + (when (re-search-forward "^[^\\*]" nil t) + (buffer-substring-no-properties + (line-beginning-position) + (point-max))))) + (local-tree default-directory)) + (when changes + (with-current-buffer "*tla-bookmarks-missing*" + (ewoc-enter-last tla-revision-list-cookie + (list 'entry-change + changes + local-tree))))))) + + + +(defun tla-bookmarks--get-local-tree () + (let ((local-trees + (cdr (assoc 'local-tree (ewoc-data (ewoc-locate tla-bookmarks-cookie)))))) + ;; todo: add support for multiple local-trees + (car local-trees))) + +(defun tla-bookmarks-open-tree () + "Open a local tree in a dired buffer." + (interactive) + (dired-other-window (tla-bookmarks--get-local-tree))) + +(defun tla-bookmarks-inventory () + "Run tla-inventory on a local tree." + (interactive) + (let ((default-directory (tla-bookmarks--get-local-tree))) + (tla-inventory t))) + +(defmacro tla-make-move-fn (ewoc-direction function cookie) + `(defun ,function () + (interactive) + (let* ((elem (ewoc-locate ,cookie)) + (next (or (,ewoc-direction ,cookie elem) elem))) + (while (and next + (eq (car (ewoc-data next)) 'separator) + (,ewoc-direction ,cookie next)) + (setq next (,ewoc-direction ,cookie next))) + (while (and next (eq (car (ewoc-data next)) 'separator)) + (setq next (,(if (eq ewoc-direction 'ewoc-next) + 'ewoc-prev + 'ewoc-next) ,cookie next))) + (when next (goto-char (ewoc-location next))))) + ) + +(tla-make-move-fn ewoc-next tla-bookmarks-missing-next + tla-revision-list-cookie) + +(tla-make-move-fn ewoc-prev tla-bookmarks-missing-prev + tla-revision-list-cookie) + + +;;;###autoload +(defun tla-bookmarks (&optional arg) + "Displays xtla bookmarks in a buffer. Non-nil prefix argument to +reload the file from disk." + (interactive "P") + (tla-bookmarks-load-from-file arg) + (pop-to-buffer "*tla-bookmarks*") + (let ((pos (point))) + (toggle-read-only -1) + (erase-buffer) + (set (make-local-variable 'tla-bookmarks-cookie) + (ewoc-create 'tla-bookmarks-printer)) + (set (make-local-variable 'tla-bookmarks-marked-list) nil) + (dolist (elem tla-bookmarks-alist) + (ewoc-enter-last tla-bookmarks-cookie elem)) + (tla-bookmarks-mode) + (if (equal pos (point-min)) + (if (ewoc-nth tla-bookmarks-cookie 0) + (tla-bookmarks-cursor-goto (ewoc-nth tla-bookmarks-cookie 0)) + (message "You have no bookmarks, create some in the other buffers")) + (goto-char pos)))) + +(defvar tla-bookmarks-mode-map () "Keymap used in tla-bookmarks-mode buffers.") + +(when (not tla-bookmarks-mode-map) + (setq tla-bookmarks-mode-map (make-sparse-keymap)) + (define-key tla-bookmarks-mode-map [??] 'describe-mode) + (define-key tla-bookmarks-mode-map "\C-m" 'tla-bookmarks-goto) + (define-key tla-bookmarks-mode-map [?S] 'tla-bookmarks-star-merge) + (define-key tla-bookmarks-mode-map [?n] 'tla-bookmarks-next) + (define-key tla-bookmarks-mode-map [?p] 'tla-bookmarks-previous) + (define-key tla-bookmarks-mode-map [?N] 'tla-bookmarks-move-down) + (define-key tla-bookmarks-mode-map [?P] 'tla-bookmarks-move-up) + (define-key tla-bookmarks-mode-map [?M] 'tla-bookmarks-missing) + (define-key tla-bookmarks-mode-map [?m] 'tla-bookmarks-mark) + (define-key tla-bookmarks-mode-map [(meta p)] + 'tla-bookmarks-marked-are-partners) + (define-key tla-bookmarks-mode-map "\M-\C-?" 'tla-bookmarks-unmark-all) + (define-key tla-bookmarks-mode-map [?* ?!] 'tla-bookmarks-unmark-all) + (define-key tla-bookmarks-mode-map [?u] 'tla-bookmarks-unmark) + (define-key tla-bookmarks-mode-map [?a] 'tla-bookmarks-add) + (define-key tla-bookmarks-mode-map [?e] 'tla-bookmarks-edit) + (define-key tla-bookmarks-mode-map [?d] 'tla-bookmarks-delete) + (define-key tla-bookmarks-mode-map [?o] 'tla-bookmarks-open-tree) + (define-key tla-bookmarks-mode-map [?i] 'tla-bookmarks-inventory) + (define-key tla-bookmarks-mode-map [?q] 'tla-buffer-quit) + (define-key tla-bookmarks-mode-map [?t] 'tla-bookmarks-toggle-details) + (define-key tla-bookmarks-mode-map [?+ ?b] 'tla-bookmarks-add) + (define-key tla-bookmarks-mode-map [?+ ?t] 'tla-bookmarks-add-tree-interactive) + (define-key tla-bookmarks-mode-map [?- ?t] 'tla-bookmarks-delete-tree-interactive) + (define-key tla-bookmarks-mode-map [?+ ?p] 'tla-bookmarks-add-partner-interactive) + (define-key tla-bookmarks-mode-map [?- ?p] 'tla-bookmarks-delete-partner-interactive) + (define-key tla-bookmarks-mode-map [?+ ?g] 'tla-bookmarks-add-group-interactive) + (define-key tla-bookmarks-mode-map [?- ?g] 'tla-bookmarks-delete-group-interactive) + (define-key tla-bookmarks-mode-map [?* ?g] 'tla-bookmarks-select-by-group) + (define-key tla-bookmarks-mode-map [?>] 'tla-bookmarks-get) + ) + +(easy-menu-define tla-bookmarks-mode-menu tla-bookmarks-mode-map + "`tla-bookmarks-mode' menu" + '("Tla-Bookmarks" + ["View missing patches" tla-bookmarks-missing t] + ["Open local tree" tla-bookmarks-open-tree t] + ["Inventory on local tree" tla-bookmarks-inventory t] + ["Add bookmark" tla-bookmarks-add t] + ["Show details" tla-bookmarks-toggle-details + :style toggle :selected tla-bookmarks-show-details] + ["Add partner" tla-bookmarks-add-partner-interactive t] + ["Remove partner" tla-bookmarks-delete-partner-interactive t] + ("Group" + ["Add group" tla-bookmarks-add-group-interactive t] + ["Delete group" tla-bookmarks-delete-group-interactive t] + ["Select by group" tla-bookmarks-select-by-group t] + ) + ["Get" tla-bookmarks-get t] + ["Cleanup 'local-tree fields" tla-bookmarks-cleanup-local-trees t] + )) + +(defun tla-bookmarks-mode () + "Major mode to show xtla bookmarks. + +You can add a bookmark with '\\<tla-bookmarks-mode-map>\\[tla-bookmarks-add]', and remove one with '\\[tla-bookmarks-delete]'. After +marking a set of files with '\\[tla-bookmarks-mark]', make them partners with '\\[tla-bookmarks-marked-are-partners]', and +you will then be able to use '\\[tla-bookmarks-missing]' to view the missing patches. + +Commands: +\\{tla-bookmarks-mode-map} +" + (interactive) + (use-local-map tla-bookmarks-mode-map) + (set (make-local-variable 'font-lock-defaults) + '(tla-bookmarks-font-lock-keywords t)) + (setq major-mode 'tla-bookmarks-mode) + (setq mode-name "tla-bookmarks") + (toggle-read-only 1) + (run-hooks 'tla-bookmarks-mode-hook)) + +(defun tla-bookmarks-cursor-goto (ewoc-bookmark) + "Move cursor to the ewoc location of EWOC-BOOKMARK" + (interactive) + (goto-char (ewoc-location ewoc-bookmark)) + (search-forward ":")) + +(defun tla-bookmarks-next () + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (next (or (ewoc-next cookie elem) elem))) + (tla-bookmarks-cursor-goto next))) + +(defun tla-bookmarks-previous () + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (previous (or (ewoc-prev cookie elem) elem))) + (tla-bookmarks-cursor-goto previous))) + +(defun tla-bookmarks-move-down () + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (data (ewoc-data elem)) + (oldname (car data)) + (next (ewoc-next cookie elem))) + (unless next + (error "Can't go lower")) + (tla-ewoc-delete cookie elem) + (goto-char (ewoc-location + (ewoc-enter-after cookie next data))) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (if (string= (caar list) oldname) + (progn + (setq newlist (cons (car (cdr list)) newlist)) + (setq newlist (cons (car list) newlist)) + (setq list (cdr list))) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + (search-forward ":"))) + +(defun tla-bookmarks-move-up () + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (data (ewoc-data elem)) + (oldname (car data)) + (previous (ewoc-prev cookie elem))) + (unless previous + (error "Can't go upper")) + (tla-ewoc-delete cookie elem) + (goto-char (ewoc-location + (ewoc-enter-before cookie previous data))) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (if (string= (caar (cdr list)) oldname) + (progn + (setq newlist (cons (car (cdr list)) newlist)) + (setq newlist (cons (car list) newlist)) + (setq list (cdr list))) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + (search-forward ":"))) + +(defun tla-bookmarks-get (directory) + (interactive (list (expand-file-name (read-directory-name "Get in directory: ")))) + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (cdr (assoc 'location elem)))) + (tla-get directory t + (tla-archive-name location) + (tla-category-name location) + (tla-branch-name location) + (tla-version-name location)))) + + +(defun tla-bookmarks-goto () + (interactive) + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (cdr (assoc 'location elem))) + (archive (tla-archive-name location)) + (category (tla-category-name location)) + (branch (tla-branch-name location)) + (version (tla-version-name location))) + (cond (version (tla-revisions archive category branch version)) + (branch (tla-versions archive category branch)) + (category (tla-branches archive category)) + (archive (tla-categories archive)) + (t (error "Nothing specified for this bookmark"))))) + +(defun tla-bookmarks-star-merge (arg) + (interactive "P") + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (cdr (assoc 'location elem))) + (local-tree (read-directory-name "Star-merge into: "))) + (tla-star-merge (apply 'tla-fully-qualified-revision location) + local-tree))) + +(defun tla-bookmarks-add-elem (name info) + "Internal function. Adds the association (name . info) to the list +of bookmarks, and saves it" + (when (assoc name tla-bookmarks-alist) + (error (concat "Already got a bookmark " name))) + (let ((elem (cons name info))) + (add-to-list 'tla-bookmarks-alist elem t) + (tla-bookmarks-save-to-file) + (ewoc-enter-last tla-bookmarks-cookie elem) + )) + +(defun tla-bookmarks-add (name archive &optional category branch version) + "adds a bookmark named NAME for location ARCHIVE/CATEGORY--BRANCH--VERSION" + (interactive (cons (read-string "Name of the bookmark: ") + (tla-split-revision-name + (read-string "Location of the bookmark: ")))) + (unless (get-buffer "*tla-bookmarks*") + (tla-bookmarks)) + (with-current-buffer "*tla-bookmarks*" + (let* ((info (list (cons 'location + (list archive category branch version)) + (cons 'timestamp (current-time-string))))) + (tla-bookmarks-add-elem name info)))) + +(defun tla-bookmarks-mark () + "Marks bookmark at point" + (interactive) + (let ((pos (point))) + (add-to-list 'tla-bookmarks-marked-list + (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (ewoc-refresh tla-bookmarks-cookie) + (goto-char pos)) + (tla-bookmarks-next)) + +(defun tla-bookmarks-unmark () + "Marks bookmark at point" + (interactive) + (let ((pos (point))) + (setq tla-bookmarks-marked-list + (delq (ewoc-data (ewoc-locate tla-bookmarks-cookie)) + tla-bookmarks-marked-list)) + (ewoc-refresh tla-bookmarks-cookie) + (goto-char pos)) + (tla-bookmarks-next)) + +(defun tla-bookmarks-unmark-all () + "Unmarks all bookmarks in current buffer" + (interactive) + (let ((pos (point))) + (setq tla-bookmarks-marked-list nil) + (ewoc-refresh tla-bookmarks-cookie) + (goto-char pos))) + +(defun tla-bookmarks-marked-are-partners () + "All marked bookmarks becomes mutual partners" + (interactive) + (let ((list-arch (mapcar + #'(lambda (x) + (format "%s" + (apply 'tla-fully-qualified-revision + (cdr (assoc 'location x))))) + tla-bookmarks-marked-list))) + (dolist (book tla-bookmarks-marked-list) + (let ((myloc (apply 'tla-fully-qualified-revision + (cdr (assoc 'location book))))) + (message myloc) + (dolist (arch list-arch) + (unless (string= myloc arch) + (tla-bookmarks-add-partner book arch t)))))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + +(defun tla-bookmarks-cleanup-local-trees () + "Remove fields local-tree from bookmarks when they don't exist" + (interactive) + (dolist (book tla-bookmarks-alist) + (let () + (dolist (local-tree (cdr (assoc 'local-tree book))) + (when (and (not (file-exists-p local-tree)) + (or tla-bookmarks-cleanup-dont-prompt + (y-or-n-p + (format + "Remove tree %s from bookmarks %s? " + local-tree + (car book))))) + (tla-bookmarks-delete-tree book local-tree t))))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + +(defun tla-bookmarks-delete (elem &optional force) + "Deletes bookmark at point" + (interactive (list (ewoc-locate tla-bookmarks-cookie))) + (let* ((data (ewoc-data elem))) + (when (or force + (yes-or-no-p (format "Delete bookmark \"%s\"? " (car data)))) + (tla-ewoc-delete tla-bookmarks-cookie elem) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (unless (string= (caar list) (car data)) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + ;; TODO could be optimized + (tla-bookmarks-save-to-file) + ))) + +(defun tla-bookmarks-find-bookmark (location) + "Finds the bookmark whose location is LOCATION" + (let ((list tla-bookmarks-alist) + result) + (while list + (when (string= (apply 'tla-fully-qualified-revision + (cdr (assoc 'location (cdar list)))) + location) + (setq result (car list)) + (setq list nil)) + (setq list (cdr list))) + result)) + +(defmacro tla-bookmarks-make-add-fn (name field message-already message-add) + `(defun ,name (bookmark value &optional dont-save) + "Adds the direcotry VALUE to the list of local trees of bookmark +BOOKMARK." + (let ((local-trees (assoc ,field (cdr bookmark)))) + (if local-trees + (if (member value (cdr local-trees)) + (message ,message-already) + (progn + (message ,message-add) + (setcdr local-trees (cons value + (cdr local-trees))))) + (progn + (message ,message-add) + (setcdr bookmark (cons (list ,field value) + (cdr bookmark))))) + (unless dont-save + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))))) + ) + +(tla-bookmarks-make-add-fn tla-bookmarks-add-tree + 'local-tree + "Local tree already in the list" + "Local tree added to your bookmarks") + +(tla-bookmarks-make-add-fn tla-bookmarks-add-partner + 'partners + "Partner already in the list" + "Partner added to your bookmarks") + +(tla-bookmarks-make-add-fn tla-bookmarks-add-group + 'groups + "Group already in the list" + "Group added to your bookmarks") + +(defmacro tla-bookmarks-make-delete-fn (name field) + `(defun ,name (bookmark value &optional dont-save) + "Deletes the directory VALUE to the list of local trees of bookmark +BOOKMARK." + (let ((local-trees (assoc ,field (cdr bookmark)))) + (when local-trees + (let ((rem-list (delete value (cdr (assoc ,field + bookmark))))) + (if rem-list + (setcdr local-trees rem-list) + ;; Remove the whole ('field ...) + (setcdr bookmark (delq local-trees (cdr bookmark)))))) + (unless dont-save + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))))) + ) + +(tla-bookmarks-make-delete-fn tla-bookmarks-delete-tree + 'local-tree) + +(tla-bookmarks-make-delete-fn tla-bookmarks-delete-partner + 'partners) + +(tla-bookmarks-make-delete-fn tla-bookmarks-delete-group + 'groups) + +(defun tla-bookmarks-add-partner-interactive () + "Adds a partner to the current or marked bookmarks" + (interactive) + (let ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (partner (apply 'tla-fully-qualified-revision + (tla-read-archive-category-branch-version-name)))) + (dolist (bookmark bookmarks) + (tla-bookmarks-add-partner bookmark partner t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-delete-partner-interactive () + "Deletes a partner from the current or marked bookmarks" + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (choices (apply 'append + (mapcar #'(lambda (x) + (cdr (assoc 'partners + (cdr x)))) + bookmarks))) + (choices-alist (mapcar #'(lambda (x) (list x)) choices)) + (partner (completing-read "Partner to remove: " choices-alist))) + (dolist (bookmark bookmarks) + (tla-bookmarks-delete-partner bookmark partner t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-add-tree-interactive () + "Adds a local tree to the current or marked bookmarks" + (interactive) + (let ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (local-tree (read-directory-name "Local tree to add: "))) + (unless (file-exists-p (concat local-tree "/{arch}")) + (error (concat local-tree " is not an arch local tree."))) + (dolist (bookmark bookmarks) + (tla-bookmarks-add-tree bookmark local-tree t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-delete-tree-interactive () + "Adds a local tree to the current or marked bookmarks" + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (choices (apply 'append + (mapcar #'(lambda (x) + (cdr (assoc 'local-tree + (cdr x)))) + bookmarks))) + (choices-alist (mapcar #'(lambda (x) (list x)) choices)) + (local-tree (completing-read "Local tree to remove: " choices-alist))) + (unless (file-exists-p (concat local-tree "/{arch}")) + (error (concat local-tree " is not an arch local tree."))) + (dolist (bookmark bookmarks) + (tla-bookmarks-delete-tree bookmark local-tree t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-list-groups () + "Returns the list of groups currently used by bookmarks" + (let ((list (apply 'append + (mapcar #'(lambda (x) + (cdr (assoc 'groups + (cdr x)))) + tla-bookmarks-alist))) + result) + ;; Make elements unique + (dolist (elem list) + (add-to-list 'result elem)) + result)) + +(defun tla-bookmarks-add-group-interactive () + "Add a group entry in the current or marked bookmarks" + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (group (completing-read "Group of bookmarks: " + (mapcar #'(lambda (x) (list x)) + (tla-bookmarks-list-groups))))) + (dolist (bookmark bookmarks) + (tla-bookmarks-add-group bookmark group t))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + + +(defun tla-bookmarks-delete-group-interactive () + "Deletes a group of bookmark entry from the current or marked bookmarks" + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (choices (apply 'append + (mapcar #'(lambda (x) + (cdr (assoc 'groups + (cdr x)))) + bookmarks))) + (choices-alist (mapcar #'(lambda (x) (list x)) choices)) + (group (completing-read "Group to remove: " choices-alist))) + (dolist (bookmark bookmarks) + (tla-bookmarks-delete-group bookmark group t))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + +(defun tla-bookmarks-select-by-group (group) + "Select all bookmarks in the group GROUP" + (interactive (list (completing-read "Group to select: " + (mapcar #'(lambda (x) (list x)) + (tla-bookmarks-list-groups))))) + (dolist (bookmark tla-bookmarks-alist) + (when (member group (cdr (assoc 'groups bookmark))) + (add-to-list 'tla-bookmarks-marked-list bookmark)) + ) + (ewoc-refresh tla-bookmarks-cookie)) + +(defvar tla-buffer-bookmark nil + "Bookmark manipulated in current buffer") + +(defun tla-bookmarks-edit () + "Edit bookmark at point" + (interactive) + (let* ((elem (ewoc-locate tla-bookmarks-cookie)) + (data (ewoc-data elem))) + (pop-to-buffer (concat "*xtla bookmark " (car data) "*")) + (erase-buffer) + (emacs-lisp-mode) + (make-local-variable 'tla-buffer-bookmark) + (setq tla-buffer-bookmark elem) + (insert ";; Edit the current bookmark. C-c C-c to finish\n\n") + (pp data (current-buffer)) + (goto-char (point-min)) (forward-line 2) (forward-char 2) + (local-set-key [(control ?c) (control ?c)] + #'(lambda () (interactive) + (goto-char (point-min)) + (let* ((newval (read (current-buffer))) + (elem tla-buffer-bookmark) + (oldname (car (ewoc-data elem)))) + (kill-buffer (current-buffer)) + (pop-to-buffer "*tla-bookmarks*") + (setcar (ewoc-data elem) (car newval)) + (setcdr (ewoc-data elem) (cdr newval)) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (if (string= (caar list) oldname) + (setq newlist (cons newval newlist)) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + (ewoc-refresh tla-bookmarks-cookie) + (tla-bookmarks-save-to-file) + ))))) + +;; +;; Archives +;; +;;;###autoload +(defun tla-archives () + (interactive) + (tla-archives-build-archive-tree) + ;;(message "archives: %S" tla-archive-tree) + (tla-switch-to-buffer "*tla-archives*") + (let ((a-list tla-archive-tree) + (my-default-archive (tla-my-default-archive)) + defaultp + archive-name + archive-location + p) + (toggle-read-only -1) + (erase-buffer) + (while a-list + (setq archive-name (caar a-list) + archive-location (cadar a-list) + a-list (cdr a-list) + defaultp (string= archive-name my-default-archive)) + (if defaultp (setq p (point))) + (tla-archives-insert-item archive-name archive-location defaultp)) + (delete-backward-char 1) + (when p (goto-char p)) + (tla-archive-list-mode))) + +(defun tla-archives-insert-item (archive location defaultp) + (let ((start-pos (point)) + overlay) + (insert (if defaultp "*" " ") + " " + (tla-choose-face-to-add + defaultp + archive 'tla-marked 'tla-archive-name)) + (newline) + (insert " " location) + (newline) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'tla-archive-info archive))) + +;; Just update tla-archive-tree. +(defun tla-archives-build-archive-tree () + (tla-run-arch nil t 'archives "archives") + (setq tla-archive-tree nil) + (save-excursion + (let ((archive-name) + (archive-location)) + (set-buffer tla-process-buffer) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq archive-name (buffer-substring-no-properties (line-beginning-position) (line-end-position))) + (beginning-of-line-text 2) + (setq archive-location (buffer-substring-no-properties (point) (line-end-position))) + (forward-line 1) + (tla-archive-tree-add-archive archive-name archive-location))))) + +(defun tla-get-archive-info (&optional property) + (unless property + (setq property 'tla-archive-info)) + (let ((overlay (car (overlays-at (point))))) + (when overlay + (overlay-get overlay property)))) + +(defun tla-my-default-archive (&optional new-default) + "Set or get the default archive. +When called with a prefix argument: Ask the user for the new default archive. +When called with a string argument: Set the default archive to this string. +When called with no argument: return the name of the default argument. +When called interactively, with no argument: Show the name of the default archive." + (interactive "P") + (when (or (numberp new-default) (and (listp new-default) (> (length new-default) 0))) + (setq new-default (car (tla-read-archive-name)))) + (cond ((stringp new-default) + (message "Setting arch default archive to: %s" new-default) + (tla-run-arch nil t 'my-default-archive "my-default-archive" new-default)) + (t + (tla-run-arch nil t 'my-default-archive "my-default-archive") + (when (interactive-p) (message "Default arch archive: %s" (tla-get-process-output))) + (tla-get-process-output)))) + +(defun tla-whereis-archive (&optional archive) + "Call tla whereis-archive. +" + (interactive "P") + (let ((location)) + (unless archive + (setq archive (tla--get-archive (tla--get-info-at-point)))) + (tla-run-arch nil t 'whereis-archive "whereis-archive" archive) + (setq location (tla-get-process-output)) + (when (interactive-p) + (message "archive location for %s: %s" archive location)) + location)) + +(defun tla-register-archive (location &optional archive) + "Register arch archive. +LOCATION should be either a local directory or a remote path. +ARCHIVE is the name is archive. If ARCHIVE is not given or an empty string, +the default name is used." + (interactive "sLocation: \nsArchive (empty for default): ") + (if (and archive (eq 0 (length archive))) + (setq archive nil)) + (let ((result (if archive + (tla-run-arch nil t 'register-archive "register-archive" archive location) + (tla-run-arch nil t 'register-archive "register-archive" location) + ))) + (when (eq result 0) + (tla-show-process-buffer-internal t) + (run-hooks 'tla-new-archive-hook)))) + +(defun tla-make-archive (name location) + "Create a new arch archive. +NAME is the global name for the archive. It must be an +email address with a fully qualified domain name, optionally +followed by \"--\" and a string of letters, digits, periods +and dashes. +LOCATION specifies the path, where the archive should be created. + +Examples for name are: +foo.bar@flups.com--public +foo.bar@flups.com--public-2004" + (interactive "sArchive name: \nFLocation: ") + (setq location (expand-file-name location)) + (if (file-directory-p location) + (error "directory is existing: %s" location)) + (tla-run-arch nil t 'make-archive "make-archive" name location) + (tla-show-process-buffer-internal t) + (run-hooks 'tla-new-archive-hook)) + +(defun tla-mirror-archive ( &optional archive location mirror) + "Creates a mirror for the archive ARCHIVE" + (interactive) + (let* ((archive-loc (or archive (car (tla-read-archive-name "Archive to mirror: ")))) + (location-loc (or location (read-string "Location of the mirror: "))) + (mirror-loc (or mirror (read-string "Name of the mirror: " + (concat archive "-MIRROR"))))) + (tla-run-arch nil t 'make-archive "make-archive" + "--mirror" archive-loc mirror-loc location-loc) + (tla-show-process-buffer-internal t) + (run-hooks 'tla-new-archive-hook))) + +(defvar tla-read-archive-history nil) +(defun tla-read-archive-name (&optional archive-prompt default) + (let ((my-default-archive (or default (tla-my-default-archive))) + a) + (unless archive-prompt + (setq archive-prompt "Archive name: ")) + (list + (progn + (tla-archives-build-archive-tree) + (setq a (completing-read + archive-prompt + tla-archive-tree + nil nil + my-default-archive + 'tla-read-archive-history + my-default-archive)) + (if (string= "" a) (setq a nil)) + a)))) + +;; +;; Categories +;; +(defun tla-categories-build-archive-tree (archive) + (tla-run-arch nil t 'categories "categories" "-A" archive) + (with-current-buffer tla-process-buffer + (let (category) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq category (buffer-substring-no-properties (line-beginning-position) (line-end-position))) + (forward-line 1) + (tla-archive-tree-add-category archive category))))) + +(defun tla-categories (archive) + (interactive (tla-read-archive-name)) + (unless archive + (setq archive (tla-my-default-archive))) + (tla-categories-build-archive-tree archive) + (tla-switch-to-buffer "*tla-categories*") + (let ((list (cddr (tla-archive-tree-get-archive archive))) + category start-pos overlay) + (toggle-read-only -1) + (erase-buffer) + ;; TODO: button to invoke tla-archives. + (insert (format "Archive: %s\n%s\n" archive + (make-string (+ (length archive) + (length "Archive: ")) ?=))) + (save-excursion + (while list + (setq category (car (car list)) + start-pos (point) + list (cdr list)) + (insert " " (tla-add-face category 'tla-category-name)) + (newline) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'tla-category-info category)) + (delete-backward-char 1))) + (tla-category-list-mode) + (set (make-local-variable 'tla-buffer-archive-name) + archive)) + +(defun tla-make-category (archive category) + "Make new category." + (interactive (tla-read-archive-category-name)) + (tla-run-arch nil t 'make-category "make-category" "-A" archive category) + (tla-show-process-buffer-internal t) + (let ((tla-buffer-archive-name archive)) + (run-hooks 'tla-make-category-hook))) + +(defvar tla-read-archive-category-history nil) +(defun tla-read-archive-category-name (&optional archive-prompt + category-prompt) + (unless category-prompt + (setq category-prompt "Category name: ")) + (let* ((l (tla-read-archive-name archive-prompt)) + (a (car l)) + c) + (when a + (tla-categories-build-archive-tree a) + (setq c (completing-read + category-prompt + (cddr (tla-archive-tree-get-archive a)) + nil nil nil + 'tla-read-archive-category-history)) + (if (string= "" c) (setq c nil))) + (list a c))) + +;; +;; Branches +;; +(defun tla-branches-build-archive-tree (archive category) + (tla-run-arch nil t 'branches "branches" "-A" archive category) + (with-current-buffer tla-process-buffer + (let (branch) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq branch (buffer-substring-no-properties (line-beginning-position) (line-end-position))) + (forward-line 1) + (tla-archive-tree-add-branch + archive + category + (car (last (tla-name-split-components branch)))))))) + +(defun tla-branches (archive category) + (interactive (tla-read-archive-category-name)) + (tla-branches-build-archive-tree archive category) + (tla-switch-to-buffer "*tla-branches*") + (let ((list (cdr (tla-archive-tree-get-category archive category))) + alength + clength + branch + start-pos + overlay) + (toggle-read-only -1) + (erase-buffer) + ;; TODO: button to invoke tla-categories and tla-archives + (setq alength (+ (length archive) (length "Archive: ")) + clength (+ (length category) (length "Category: "))) + (insert (format "Archive: %s\nCategory: %s\n%s\n" archive category + (make-string (max alength clength) ?=))) + (save-excursion + (while list + (setq branch (car (car list)) + start-pos (point) + list (cdr list)) + (insert " " (tla-add-face branch 'tla-branch-name)) + (newline) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'tla-branch-info branch)) + (delete-backward-char 1))) + (tla-branch-list-mode) + (set (make-local-variable 'tla-buffer-archive-name) + archive) + (set (make-local-variable 'tla-buffer-category-name) + category)) + +(defvar tla-read-archive-category-branch-history nil) +(defun tla-read-archive-category-branch-name (&optional archive-prompt + category-prompt + branch-prompt) + (unless branch-prompt + (setq branch-prompt "Branch name: ")) + (let* ((l (tla-read-archive-category-name + archive-prompt + category-prompt)) + (a (car l)) + (c (cadr l)) + b) + (when c + (tla-branches-build-archive-tree a c) + (setq b (completing-read + branch-prompt + (cdr (tla-archive-tree-get-category a c)) + nil nil nil + 'tla-read-archive-category-branch-history)) + (if (string= "" b) (setq b nil))) + (list a c b))) + +(defun tla-make-branch (archive category branch) + "Make new branch." + (interactive (tla-read-archive-category-branch-name)) + (tla-run-arch nil t 'make-branch "make-branch" "-A" archive + (tla-name-construct category branch)) + (tla-show-process-buffer-internal t) + (let ((tla-buffer-archive-name archive) + (tla-buffer-category-name category)) + (run-hooks 'tla-make-branch-hook))) + +;; +;; Versions +;; +(defun tla-versions (archive category branch) + (interactive (tla-read-archive-category-branch-name)) + (tla-versions-build-archive-tree archive category branch) + (tla-switch-to-buffer "*tla-versions*") + (let ((list (cdr (tla-archive-tree-get-branch + archive category branch))) + alength + clength + blength + version + start-pos + overlay) + (toggle-read-only -1) + (erase-buffer) + ;; TODO: button to invoke tla-categories and tla-archives + (setq alength (+ (length archive) (length "Archive: ")) + clength (+ (length category) (length "Category: ")) + blength (+ (length branch) (length "Branch: "))) + (insert (format "Archive: %s\nCategory: %s\nBranch: %s\n%s\n" + archive category branch + (make-string (max alength clength blength) ?=))) + (save-excursion + (while list + (setq version (car (car list)) + start-pos (point) + list (cdr list)) + (insert " " (tla-add-face version 'tla-version-name)) + (newline) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'tla-version-info version)) + (delete-backward-char 1))) + (tla-version-list-mode) + (set (make-local-variable 'tla-buffer-archive-name) archive) + (set (make-local-variable 'tla-buffer-category-name) category) + (set (make-local-variable 'tla-buffer-branch-name) branch)) + +(defun tla-versions-build-archive-tree (archive category branch) + (tla-run-arch nil t 'versions "versions" "-A" archive + (tla-name-construct category branch)) + (with-current-buffer tla-process-buffer + (let (version) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq version (buffer-substring-no-properties (line-beginning-position) (line-end-position))) + (forward-line 1) + (tla-archive-tree-add-version + archive + category + branch + (car (last (tla-name-split-components version)))))))) + +(defvar tla-read-archive-category-branch-version-history nil) +(defun tla-read-archive-category-branch-version-name (&optional archive-prompt + category-prompt + branch-prompt + version-prompt) + (unless version-prompt + (setq version-prompt "Version name: ")) + (let* ((l (tla-read-archive-category-branch-name + archive-prompt + category-prompt + branch-prompt)) + (a (car l)) + (c (cadr l)) + (b (caddr l)) + v) + (when b + (tla-versions-build-archive-tree a c b) + (setq v (completing-read + version-prompt + (cdr (tla-archive-tree-get-branch a c b)) + nil nil nil + 'tla-read-archive-category-branch-version-history + )) + (if (string= "" v) (setq v nil))) + (list a c b v))) + +(defun tla-make-version (archive category branch version) + "Make new version." + (interactive (tla-read-archive-category-branch-version-name)) + (tla-run-arch nil t 'make-branch "make-version" "-A" archive + (tla-name-construct category branch version)) + (tla-show-process-buffer-internal t) + (let ((tla-buffer-archive-name archive) + (tla-buffer-category-name category) + (tla-buffer-branch-name branch)) + (run-hooks 'tla-make-version-hook))) + +;; +;; Revisions +;; +(defvar tla-revisions-shows-summary t + "* Wether summary should be displayed for `tla-revisions'") +(defvar tla-revisions-shows-creator t + "* Wether creator should be displayed for `tla-revisions'") +(defvar tla-revisions-shows-date t + "* Wether date should be displayed for `tla-revisions'") + + +;; elem should be +;; ('separator "string" kind) +;; or +;; ('entry-patch nil revision summary creator date) +;; ('entry-change "changes") +;; The second element tells if the element is marked or not. +(defun tla-revision-list-printer (elem) + (case (car elem) + (entry-patch (insert (if (cadr elem) " *" " ") + ;; The revision is in library? + (if (apply 'tla-library-find + (append (caddr elem) '(t))) + "L " " ") + (tla-add-face (apply 'tla-fully-qualified-revision + (caddr elem)) + 'tla-revision-name)) + (when tla-revisions-shows-summary + (insert "\n " (cadddr elem))) + (when tla-revisions-shows-creator + (insert "\n " (cadddr (cdr elem)))) + (when tla-revisions-shows-date + (insert "\n " (cadddr (cddr elem))))) + (entry-change (insert (cadr elem))) + (separator + (case (caddr elem) + (partner (insert "\n" (tla-add-face (cadr elem) + 'tla-separator))) + (bookmark (insert "\n" (tla-add-face + (concat "*** " + (cadr elem) + " ***") + 'tla-separator) "\n")))) + )) + +(defun tla-tree-revisions () + "Calls `tla-revisions` in the current tree" + (interactive) + (let ((version (tla-tree-version-list))) + (unless version + (error "not in a project tree")) + (apply 'tla-revisions version))) + +(defvar tla-revisions-tree-contains-details nil + "Wether the revision tree contains summary/date/creator +information") + +;;;###autoload +(defun tla-revisions (archive category branch version &optional update-display) + (interactive (tla-read-archive-category-branch-version-name)) + (unless (and update-display + (or tla-revisions-tree-contains-details + (not (or tla-revisions-shows-summary + tla-revisions-shows-creator + tla-revisions-shows-date)))) + (tla-revisions-build-archive-tree archive category branch version)) + (tla-switch-to-buffer "*tla-revisions*") + (let ((list (cdr (tla-archive-tree-get-version + archive category branch version))) + alength + clength + blength + vlength + revision + summary + creator + date) + (tla-revision-list-mode) + (toggle-read-only -1) + (erase-buffer) + (set (make-local-variable 'tla-revision-list-cookie) + (ewoc-create 'tla-revision-list-printer)) + (set (make-local-variable 'tla-buffer-refresh-function) + 'tla-revision-refresh) + ;; TODO: button to invoke tla-categories and tla-archives + (setq alength (+ (length archive) (length "Archive: ")) + clength (+ (length category) (length "Category: ")) + blength (+ (length branch) (length "Branch: ")) + vlength (+ (length version) (length "Version: ")) + ) + (ewoc-set-hf tla-revision-list-cookie + (format "Archive: %s\nCategory: %s\nBranch: %s\nVersion: %s\n%s\n" + archive category branch version + (make-string (max alength clength blength + vlength) ?=)) + (make-string (max alength clength blength + vlength) ?=)) + (while list + (setq revision (car (car list)) + summary (car (cdr (car list))) + creator (car (cddr (car list))) + date (car (cdddr (car list))) + list (cdr list)) + (ewoc-enter-last tla-revision-list-cookie + (list 'entry-patch nil + (list archive + category + branch + version + revision) + summary creator date)) + )) + (set (make-local-variable 'tla-buffer-archive-name) archive) + (set (make-local-variable 'tla-buffer-category-name) category) + (set (make-local-variable 'tla-buffer-branch-name) branch) + (set (make-local-variable 'tla-buffer-version-name) version) + (goto-char (point-min)) + (re-search-forward "^$") + (forward-line 1) + (toggle-read-only t)) + +(defun tla-revisions-build-archive-tree (archive category branch version) + (let ((details (or tla-revisions-shows-summary + tla-revisions-shows-date + tla-revisions-shows-creator))) + (if details + (progn + (tla-run-arch nil t 'revisions "revisions" "-A" archive + "--summary" "--date" "--creator" + (tla-name-construct category branch version)) + (setq tla-revisions-tree-contains-details t)) + (progn + (tla-run-arch nil t 'revisions "revisions" "-A" archive + (tla-name-construct category branch version)) + (setq tla-revisions-tree-contains-details nil))) + (with-current-buffer tla-process-buffer + (let (revision date creator summary) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq revision (buffer-substring-no-properties (line-beginning-position) (line-end-position))) + (forward-line 1) + (when details + (re-search-forward " *" (line-end-position)) + (setq date (buffer-substring-no-properties (point) + (line-end-position))) + (forward-line 1) + (re-search-forward " *" (line-end-position)) + (setq creator (buffer-substring-no-properties (point) + (line-end-position))) + (forward-line 1) + (re-search-forward " *" (line-end-position)) + (setq summary (buffer-substring-no-properties (point) + (line-end-position))) + (forward-line 1)) + (tla-archive-tree-add-revision + archive + category + branch + version + revision + summary + creator + date)))))) + +(defvar tla-missing-buffer-local-tree nil) +(defvar tla-missing-buffer-location nil) + +;;;###autoload +(defun tla-missing (local-tree location) + "Runs tla missing in the directory LOCAL-TREE" + (interactive (list (expand-file-name + (read-directory-name + "Search missing patches in directory: " + default-directory default-directory t nil)) + (read-string "From location: " + (tla-tree-version)))) + (pop-to-buffer (get-buffer-create "*tla-missing*")) + (tla-revision-list-mode) + (set (make-local-variable 'tla-missing-buffer-local-tree) + local-tree) + (set (make-local-variable 'tla-missing-buffer-location) + location) + (set (make-local-variable 'tla-buffer-refresh-function) + 'tla-missing-refresh) + (tla-missing-refresh)) + +(defun tla-missing-refresh () + "Refresh a *tla-missing* buffer" + (let (buffer-read-only) (erase-buffer)) + (setq tla-bookmarks-missing-buffer-todolist + `((missing ,tla-missing-buffer-local-tree + ,tla-missing-buffer-location nil))) + (set (make-local-variable 'tla-revision-list-cookie) + (ewoc-create 'tla-revision-list-printer)) + (tla-bookmarks-missing-do-todolist) + ) + +(defun tla-fully-qualified-revision (archive &optional + category + branch + version + revision) + "Creates the fully qualified revision name : +archive/category--branch--version--revision. The arguments may be +nil." + (concat + (and archive (concat archive "/")) + (tla-name-construct category branch version revision))) + +(defun tla-archive-name (list) + "LIST must be a full revision in the form of a list." + (car list)) + +(defun tla-category-name (list) + "LIST must be a full revision in the form of a list." + (cadr list)) + +(defun tla-branch-name (list) + "LIST must be a full revision in the form of a list." + (caddr list)) + +(defun tla-version-name (list) + "LIST must be a full revision in the form of a list." + (cadddr list)) + +(defun tla-revision-name (list) + "LIST must be a full revision in the form of a list." + (cadddr (cdr list))) + +(defun tla-split-revision-name (name) + "Parses a fully qualified revision name, but possibly incomplete. +email@address.com--arch/cat--branch--ver -> + (\"email@address.com--arch\" \"cat\" \"branch\" \"ver\") +email@address.com--arch/cat -> + (\"email@address.com--arch\" \"cat\" nil nil)" + (if (string-match "\\(.*\\)/\\(.*\\)" name) + (cons (match-string 1 name) + (tla-name-split-components (match-string 2 name) 4)))) + +(defvar tla-read-archive-category-branch-version-revision-history nil) +(defun tla-read-archive-category-branch-version-revision-name (&optional archive-prompt + category-prompt + branch-prompt + version-prompt + revision-prompt) + (unless revision-prompt + (setq revision-prompt "Revision name: ")) + (let* ((l (tla-read-archive-category-branch-version-name + archive-prompt + category-prompt + branch-prompt + version-prompt)) + (a (tla-archive-name l)) + (c (tla-category-name l)) + (b (tla-branch-name l)) + (v (tla-version-name l)) + r) + (when v + (tla-revisions-build-archive-tree a c b v) + (setq r (completing-read + revision-prompt + (cdr (tla-archive-tree-get-version a c b v)) + nil nil nil + 'tla-read-archive-category-branch-version-revision-history))) + (if (string= "" r) (setq r nil)) + (list a c b v r))) + +;; +;; Rbrowse interface +;; +;; TODO: Use tree-widget. +(defun tla-browse-archive (archive) + (interactive (tla-read-archive-name)) + (unless archive + (setq archive (tla-my-default-archive))) + (tla-run-arch nil t 'rbrowse "rbrowse" "-A" archive) + (tla-show-process-buffer-internal t)) + +;; +;; Get +;; +(defun tla-get (directory run-dired-p archive category branch + &optional version revision) + ;; run-dired-p => t, nil, ask + (interactive (let* ((l (tla-read-archive-category-branch-version-revision-name)) + (name (apply 'tla-name-construct (remove nil l))) + (d (read-directory-name (format "Store \"%s\" to: " name)))) + (cons d (cons 'ask l)))) + (let* ((name (tla--get-revision + (apply 'tla-fully-qualified-revision + (list archive category branch version + revision)))) + (result (tla-run-arch nil t 'get "get" "-A" archive name + directory))) + (when (eq 0 result) + (tla-run-arch nil t 'get "get" name directory) + (let ((bookmark (tla-bookmarks-find-bookmark (tla-fully-qualified-revision + archive category branch + version)))) + (when bookmark + (tla-bookmarks-add-tree bookmark directory))) + (case run-dired-p + (ask (when (y-or-n-p (format "Run dired at %s? " directory)) + (dired directory))) + (t (dired directory)))))) + +;; +;; Cacherev +;; +;; TODO: +;; - run this asynchronous +;; - provide the way to run interactively +;; - show progress +;; +(defun tla-cache-revision (archive category branch version revision) + (let ((result (tla-run-arch nil t 'cacherev "cacherev" "-A" archive + (tla-name-construct category branch version revision)))) + (pop-to-buffer tla-process-buffer) + (message "Exit status: %d" result) + result)) + +;; +;; Add +;; +(defun tla-add (id &rest files) + (interactive (let ((name + (read-file-name "Add file as source: " + nil nil t + (file-name-nondirectory (or + (buffer-file-name) "")))) + (id (read-string "id (empty for default): "))) + (list id name))) + (if (and id (string= id "")) + (setq id nil)) + (setq files (mapcar 'expand-file-name files)) + (if id + (apply 'tla-run-arch nil t 'add "add" "--id" id files) + (apply 'tla-run-arch nil t 'add "add" files))) + +;; +;; Remove +;; +(defun tla-remove (only-id &rest files) + (interactive (let ((name + (read-file-name "Remove file: " + nil nil t + (file-name-nondirectory (or + (buffer-file-name) "")))) + (only-id (not (y-or-n-p "Delete the file locally also? ")))) + (list only-id name))) + (setq files (mapcar 'expand-file-name files)) + (let ((cmd (if only-id "delete-id" "rm"))) + (apply 'tla-run-arch nil t 'delete cmd files))) + +;; +;; Update +;; +(defun tla-update (tree) + (interactive (list (expand-file-name + (read-directory-name "Update tree: " nil nil nil "")))) + (or (tla-save-some-buffers tree) + (y-or-n-p + "Update may delete unsaved changes. Continue anyway? ") + (error "Not updating")) + (pop-to-buffer tla-process-buffer) + (cd tree) + (tla-run-arch nil t 'tla-update "update") + (tla-revert-some-buffers tree)) + +;; +;; Import +;; +;;;###autoload +(defun tla-start-project () + "Start a new project. +Prompts for the root directory of the project and the fully +qualified version name to use. Sets up and imports the tree and +displays an inventory buffer to allow the project's files to be +added and committed." + (interactive) + (let* ((base (read-directory-name "Directory containing files to import: " + (if (buffer-file-name) + (file-name-directory + (buffer-file-name)) + (getenv "HOME")))) + (l (tla-read-archive-category-branch-version-name)) + (project (if (member nil l) + (error "Need a fully qualified version name") + (apply 'tla-fully-qualified-revision l)))) + (let ((default-directory (concat base "/"))) + (unless (zerop (tla-run-arch nil t 'init-tree "init-tree" + project)) + (pop-to-buffer tla-error-buffer) + (error "Could not initialise %s" project)) + (unless (zerop (tla-run-arch nil t 'import "import" "--setup")) + (pop-to-buffer tla-error-buffer) + (error "Import of %s failed" project))) + (tla-inventory base t))) + + +;; ---------------------------------------------------------------------------- +;; xtla partner stuff +;; ---------------------------------------------------------------------------- +(defun tla-partner-find-partner-file () + "Do find-file tla-parterns file and return the buffer." + (interactive) + (find-file (concat (tla-tree-root) "/++tla-partners"))) + +(defun tla-partner-read (&optional prompt) + (apply 'tla-fully-qualified-revision + (tla-read-archive-category-branch-version-name + (when prompt (concat prompt "[Archive name] ")) + (when prompt (concat prompt "[Category name] ")) + (when prompt (concat prompt "[Branch name] ")) + (when prompt (concat prompt "[Version name] ")) + ))) + +(defun tla-partner-add (partner) + "Add a partner for this xtla working copy. +Return nil if PARTNER is alerady in partners file. +For example: Franz.Lustig@foo.bar--public/tla--main--0.1" + (interactive (list (tla-partner-read))) + (let ((list (tla-partner-list))) + (if (member partner list) + nil + (with-current-buffer (tla-partner-find-partner-file) + (goto-char (point-min)) + (insert partner) + (newline) + (save-buffer) + (kill-buffer (current-buffer))) + partner))) + +(defun tla-partner-list () + (with-current-buffer (tla-partner-find-partner-file) |
