summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--awesomerc/rc-choose.lua57
-rw-r--r--awesomerc/rc-git/cal.lua121
-rw-r--r--awesomerc/rc-git/danburn/awesome-icon.pngbin0 -> 177 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/dwindle.pngbin0 -> 196 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/fairh.pngbin0 -> 191 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/fairv.pngbin0 -> 193 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/floating.pngbin0 -> 189 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/fullscreen.pngbin0 -> 199 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/magnifier.pngbin0 -> 191 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/max.pngbin0 -> 276 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/spiral.pngbin0 -> 196 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/tile.pngbin0 -> 189 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/tilebottom.pngbin0 -> 186 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/tileleft.pngbin0 -> 188 bytes
-rw-r--r--awesomerc/rc-git/danburn/layouts/tiletop.pngbin0 -> 186 bytes
-rw-r--r--awesomerc/rc-git/danburn/taglist/squarefz.pngbin0 -> 168 bytes
-rw-r--r--awesomerc/rc-git/danburn/taglist/squarez.pngbin0 -> 171 bytes
-rw-r--r--awesomerc/rc-git/danburn/theme.lua127
-rw-r--r--awesomerc/rc-git/danburn/titlebar/close_focus.pngbin0 -> 211 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/close_normal.pngbin0 -> 370 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/floating_focus_active.pngbin0 -> 210 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.pngbin0 -> 339 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/floating_normal_active.pngbin0 -> 361 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.pngbin0 -> 328 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/maximized_focus_active.pngbin0 -> 202 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.pngbin0 -> 337 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/maximized_normal_active.pngbin0 -> 369 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.pngbin0 -> 349 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/ontop_focus_active.pngbin0 -> 188 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.pngbin0 -> 333 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/ontop_normal_active.pngbin0 -> 349 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.pngbin0 -> 334 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/sticky_focus_active.pngbin0 -> 199 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.pngbin0 -> 330 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/sticky_normal_active.pngbin0 -> 361 bytes
-rw-r--r--awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.pngbin0 -> 329 bytes
-rw-r--r--awesomerc/rc-git/danburn/zenburn-background.pngbin0 -> 9477 bytes
-rw-r--r--awesomerc/rc-git/djas.lua47
-rw-r--r--awesomerc/rc-git/init-pre-shifty.lua391
-rw-r--r--awesomerc/rc-git/init.lua242
-rw-r--r--awesomerc/rc-git/keysetup.lua165
-rw-r--r--awesomerc/rc-git/naughtyaugment.lua49
-rw-r--r--awesomerc/rc-git/reloader.lua300
-rw-r--r--awesomerc/rc-git/shifty.lua845
-rw-r--r--awesomerc/rc-git/shiftyconfig.lua107
-rw-r--r--default-dotfiles/config__awesome__rc.lua7
-rw-r--r--default-dotfiles/emacs2
-rw-r--r--default-dotfiles/gtkrc-2.010
-rw-r--r--default-dotfiles/mairixrc10
-rw-r--r--default-dotfiles/muttrc1
-rw-r--r--default-dotfiles/offlineimaprc140
-rw-r--r--default-dotfiles/vimrc5
-rw-r--r--default-dotfiles/zshenv2
-rw-r--r--default-dotfiles/zshrc5
-rw-r--r--emacs-lisp/custom-resources.el59
-rw-r--r--emacs-lisp/dot.emacs.el101
-rw-r--r--emacs-lisp/dot.emacs.el.orig99
-rw-r--r--emacs-lisp/general/load-modes.el74
-rw-r--r--emacs-lisp/general/machine-settings.el71
-rw-r--r--emacs-lisp/general/mic-paren.el1445
-rw-r--r--emacs-lisp/general/project-local.el30
-rw-r--r--emacs-lisp/general/redo.el189
-rw-r--r--emacs-lisp/general/rfc1345.elbin0 -> 31752 bytes
-rw-r--r--emacs-lisp/general/settings.el42
-rw-r--r--emacs-lisp/general/tempo-snippets.el514
-rw-r--r--emacs-lisp/modes/cmode-stuff.el37
-rw-r--r--emacs-lisp/modes/fill-column-indicator.el814
-rw-r--r--emacs-lisp/modes/hfy.el728
-rw-r--r--emacs-lisp/modes/linum.el204
-rw-r--r--emacs-lisp/modes/lua.el1096
-rw-r--r--emacs-lisp/modes/p4.el3682
-rw-r--r--emacs-lisp/modes/perl-stuff.el6
-rw-r--r--emacs-lisp/modes/plsql.el409
-rw-r--r--emacs-lisp/modes/vala-mode.el395
-rw-r--r--emacs-lisp/modes/xtla.el5497
-rw-r--r--mutt/aliases.petitemort.rc38
-rw-r--r--mutt/aliases.somnambulist.rc9
-rw-r--r--mutt/colour.rc34
-rw-r--r--mutt/headers.rc5
-rw-r--r--mutt/hooks.rc39
-rw-r--r--mutt/keys.rc67
-rw-r--r--mutt/mailboxes.rc46
-rw-r--r--mutt/maillists.rc1
-rw-r--r--mutt/main.rc427
-rw-r--r--mutt/signature.netsurf2
-rw-r--r--mutt/signature.normal2
-rw-r--r--mutt/signature.pepperfish2
-rw-r--r--mutt/signature.pepperfishadmin1
-rw-r--r--mutt/signature.simtec2
-rw-r--r--offlineimap/extras.py60
-rwxr-xr-xscripts/add-mailcreds46
-rwxr-xr-xscripts/print-mailcreds67
-rwxr-xr-xscripts/tree-relink65
-rw-r--r--settings/ls/dircolors86
-rw-r--r--shared/codethink.sieve14
-rw-r--r--shared/dsilvers@digital-scurf.org.sieve100
-rw-r--r--shared/simtec.sieve95
-rwxr-xr-xshared/uploadsieve2
-rwxr-xr-xtools/gnome-encfs423
-rwxr-xr-xtools/install-defaults24
-rw-r--r--zsh/complete/_bzr316
-rw-r--r--zsh/rc26
-rw-r--r--zsh/rc.d/00-entitle39
-rw-r--r--zsh/rc.d/10-ls23
-rw-r--r--zsh/rc.d/20-ssh22
-rw-r--r--zsh/rc.d/30-settings28
-rw-r--r--zsh/rc.d/40-prompt343
-rw-r--r--zsh/rc.d/50-completions9
-rw-r--r--zsh/rc.d/60-locals27
-rw-r--r--zsh/rc.d/70-variables9
-rw-r--r--zsh/rc.d/80-functions14
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
new file mode 100644
index 0000000..70978d3
--- /dev/null
+++ b/awesomerc/rc-git/danburn/awesome-icon.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/dwindle.png b/awesomerc/rc-git/danburn/layouts/dwindle.png
new file mode 100644
index 0000000..1aa4bf2
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/dwindle.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/fairh.png b/awesomerc/rc-git/danburn/layouts/fairh.png
new file mode 100644
index 0000000..e176bb3
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/fairh.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/fairv.png b/awesomerc/rc-git/danburn/layouts/fairv.png
new file mode 100644
index 0000000..7c0a92c
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/fairv.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/floating.png b/awesomerc/rc-git/danburn/layouts/floating.png
new file mode 100644
index 0000000..a399092
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/floating.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/fullscreen.png b/awesomerc/rc-git/danburn/layouts/fullscreen.png
new file mode 100644
index 0000000..a0c795c
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/fullscreen.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/magnifier.png b/awesomerc/rc-git/danburn/layouts/magnifier.png
new file mode 100644
index 0000000..bca6db9
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/magnifier.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/max.png b/awesomerc/rc-git/danburn/layouts/max.png
new file mode 100644
index 0000000..96a237a
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/max.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/spiral.png b/awesomerc/rc-git/danburn/layouts/spiral.png
new file mode 100644
index 0000000..8f5aeed
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/spiral.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/tile.png b/awesomerc/rc-git/danburn/layouts/tile.png
new file mode 100644
index 0000000..3fcc904
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/tile.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/tilebottom.png b/awesomerc/rc-git/danburn/layouts/tilebottom.png
new file mode 100644
index 0000000..dfe7832
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/tilebottom.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/tileleft.png b/awesomerc/rc-git/danburn/layouts/tileleft.png
new file mode 100644
index 0000000..c5decfd
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/tileleft.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/layouts/tiletop.png b/awesomerc/rc-git/danburn/layouts/tiletop.png
new file mode 100644
index 0000000..b251661
--- /dev/null
+++ b/awesomerc/rc-git/danburn/layouts/tiletop.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/taglist/squarefz.png b/awesomerc/rc-git/danburn/taglist/squarefz.png
new file mode 100644
index 0000000..0927720
--- /dev/null
+++ b/awesomerc/rc-git/danburn/taglist/squarefz.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/taglist/squarez.png b/awesomerc/rc-git/danburn/taglist/squarez.png
new file mode 100644
index 0000000..9b41c26
--- /dev/null
+++ b/awesomerc/rc-git/danburn/taglist/squarez.png
Binary files differ
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
new file mode 100644
index 0000000..02565b9
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/close_focus.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/close_normal.png b/awesomerc/rc-git/danburn/titlebar/close_normal.png
new file mode 100644
index 0000000..982da6c
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/close_normal.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/floating_focus_active.png b/awesomerc/rc-git/danburn/titlebar/floating_focus_active.png
new file mode 100644
index 0000000..63d900b
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/floating_focus_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.png
new file mode 100644
index 0000000..461ab52
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/floating_focus_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/floating_normal_active.png b/awesomerc/rc-git/danburn/titlebar/floating_normal_active.png
new file mode 100644
index 0000000..9e6a239
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/floating_normal_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.png
new file mode 100644
index 0000000..df28637
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/floating_normal_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_focus_active.png b/awesomerc/rc-git/danburn/titlebar/maximized_focus_active.png
new file mode 100644
index 0000000..834f106
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/maximized_focus_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.png
new file mode 100644
index 0000000..55ff310
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/maximized_focus_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_normal_active.png b/awesomerc/rc-git/danburn/titlebar/maximized_normal_active.png
new file mode 100644
index 0000000..98f5522
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/maximized_normal_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.png
new file mode 100644
index 0000000..a2d0ff1
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/maximized_normal_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_focus_active.png b/awesomerc/rc-git/danburn/titlebar/ontop_focus_active.png
new file mode 100644
index 0000000..776d586
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/ontop_focus_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.png
new file mode 100644
index 0000000..f677f15
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/ontop_focus_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_normal_active.png b/awesomerc/rc-git/danburn/titlebar/ontop_normal_active.png
new file mode 100644
index 0000000..e70de36
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/ontop_normal_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.png
new file mode 100644
index 0000000..754b9bb
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/ontop_normal_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_focus_active.png b/awesomerc/rc-git/danburn/titlebar/sticky_focus_active.png
new file mode 100644
index 0000000..1726f90
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/sticky_focus_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.png b/awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.png
new file mode 100644
index 0000000..efc020f
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/sticky_focus_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_normal_active.png b/awesomerc/rc-git/danburn/titlebar/sticky_normal_active.png
new file mode 100644
index 0000000..c87f21a
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/sticky_normal_active.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.png b/awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.png
new file mode 100644
index 0000000..0b24f37
--- /dev/null
+++ b/awesomerc/rc-git/danburn/titlebar/sticky_normal_inactive.png
Binary files differ
diff --git a/awesomerc/rc-git/danburn/zenburn-background.png b/awesomerc/rc-git/danburn/zenburn-background.png
new file mode 100644
index 0000000..1eb9437
--- /dev/null
+++ b/awesomerc/rc-git/danburn/zenburn-background.png
Binary files differ
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 &lt;gkusnierz@gmail.com&gt;
+-- @author bioe007 &lt;perry.hargrave@gmail.com&gt;
+--
+-- 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 Sjdin (mic@docs.uu.se)
+;; Klaus Berndl <berndl@sdm.de>
+;; Keywords: languages, faces, parenthesis, matching
+;;
+;; Additional info:
+;; Copyright (C) 1997 Mikael Sjdin (mic@docs.uu.se)
+;; Maintenance and development (since v2.1): Klaus Berndl <berndl@sdm.de>
+;; Original author: Mikael Sjdin -- 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 its 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
new file mode 100644
index 0000000..87c62b2
--- /dev/null
+++ b/emacs-lisp/general/rfc1345.el
Binary files differ
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 '(("\"" "&quot;")
+ ("<" "&lt;" )
+ (">" "&gt;" )))) )
+
+;; 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)