branch: scratch/hyperbole-lexbind commit c547ad4fab47ea266d30eeabe9402a2a215b8ddc Merge: 9ad2bf0 da8f3fa Author: Robert Weiner <r...@gnu.org> Commit: GitHub <nore...@github.com>
Merge branch '7.0.3a' into prepare-pr-for-merging --- Changes | 201 +++++++++++++++++ DEMO | 5 +- HY-ANNOUNCE | 207 +++++++++++++++++ HY-NEWS | 14 +- hactypes.el | 53 ++++- hargs.el | 7 +- hbut.el | 644 ++++++++++++++++++++++++++++++++++++----------------- hib-kbd.el | 17 +- hibtypes.el | 141 ++++++++++-- hpath.el | 46 ++-- hsys-org.el | 211 ++++++++++++++++-- htz.el | 45 ++-- hui-mouse.el | 4 +- hui.el | 22 +- hypb.el | 17 +- hyperbole.el | 2 +- hyrolo.el | 59 +++-- kotl/kfill.el | 97 ++++---- kotl/kotl-mode.el | 14 +- kotl/kvspec.el | 59 +++-- man/hyperbole.texi | 107 +++++---- 21 files changed, 1481 insertions(+), 491 deletions(-) diff --git a/Changes b/Changes index 2989b2b..0815d4e 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,204 @@ +2019-07-13 Bob Weiner <r...@gnu.org> + +* hsys-org.el (org-set-ibut-label): Added and used in org-mode ibtype. + (org-mode, org-at-block-start-p): Added Action Key activation of Org blocks when + on 1st line of def. + +* hibtypes.el (link-to-gbut, glink:start, glink:end): Added for in-buffer links to global buttons. + (link-to-ebut, elink:start, elink:end): Added for in-buffer links to explicit buttons. + (link-to-ibut, ilink:start, ilink:end): Added for in-buffer links to implicit buttons. + +* hbut.el (ebut:label-p): Updated to better handle whether point is + between specified delimiters. + +2019-07-12 Bob Weiner <r...@gnu.org> + +* hbut.el (ebut:key-src-set-buffer, hbut:key-src-set-buffer, hbut:key-list, + hbut:ebut-key-list, hbut:ibut-key-list, hbut:label-list): Added + to allow selection of labeled Hyperbole buttons in currrent buffer by name. + (ibut:to): Added to move to an implicit button in the current buffer + matching a label key. + +2019-07-11 Bob Weiner <r...@gnu.org> + +* hargs.el (hargs:at-p): Added support for reading global button arguments. + +* hactypes.el (link-to-gbut): Updated to handle global labeled implicit buttons. + +* hbut.el (gbut:get): Added. + +2019-07-10 Bob Weiner <r...@gnu.org> + +* man/hyperbole.texi (Invisible Text Searches): Added missing {M-s i} key sequence. + +* hibtypes.el (Info-node): Modified to skip costly hpath:is-p if ref + string is not of the right format. + (hibtypes-path-line-and-col-regexp, pathname-line-and-column): Updated + to handle Elisp variables with colons. + +2019-07-09 Bob Weiner <r...@gnu.org> + +* hbut.el (ibut:at-p): Conditionalized on (not (hbut:outside-comment-p)). + (hbut:map, ibut:label-map): Added. + (ibut:key-src, ibut:key-to-label, ibut:label-to-key, ibut:summarize): Added. + Global, labeled implicit buttons now exist! + +2019-07-08 Bob Weiner <r...@gnu.org> + +* hbut.el (ibut:label-separator, hbut:outside-comment-p): Added. + +2019-07-01 Bob Weiner <r...@gnu.org> + +* hbut.el (gbut:ibut-key-list): Added. + +* hui.el (hui:hbut-term-highlight, hui:hbut-term-unhighlight): Fixed so save-excursion is outermost. + +2019-06-29 Bob Weiner <r...@gnu.org> + +* hbut.el (ebut:get, ebut:at-p, ebut:label-to-key, ibut:at-type-p): Simplified conditionals using 'when'. + (ibut:label-start, ibut:label-end, ibut:label-p, ibut:get, + ibut:next-occurrence, ibut:label-regexp): Added. + (hbut:label-regexp): Added to support labeled implicit buttons too. + (ebut:label-regexp): Aliased to hbut:label-regexp. + (hbut:label-p): Updated to handle implicit button labels. + +2019-06-23 Bob Weiner <r...@gnu.org> + +* hsys-org.el: Added many new predicates and code to handle navigation between Org + mode internal links and their targets, as well as radio target definitions and their links. + (hsys-org-mode-function, hsys-org-mode-p): Added to determine when hsys-org actions + are activated. + +* hypb.el (hypb:region-with-text-property-value): Added and used in hysy-org.el. + +* kotl/kfill.el (set-fill-prefix): Updated to better match standard Emacs functiion. + +2019-06-22 Bob Weiner <r...@gnu.org> + +* hyrolo.el (hyrolo-add): Fixed bug in call to match-string-no-properties. + +2019-06-21 Bob Weiner <r...@gnu.org> + +* kotl/kotl-mode.el (kotl-mode): Set fill-paragraph-function rather than overloading + fill-paragraph. + kotl/kfill.el (kfill:fill-paragraph): Renamed and used only in kotl-mode. Also + temporarily set fill-paragraph-handle-comment to t and made prefix arg optional. + (kfill:funcall): Removed. + (kfill:function-table): Removed. + (kfill:do-auto-fill): Temporarily set fill-paragraph-handle-comment to t. + +2019-06-20 Bob Weiner <r...@gnu.org> + +* hsys-org.el (org-link): Changed to call org-open-at-point which handles internal + org links, fixing following links such as radio targets. + (org-thing-at-p, org-target-at-p): Added. + +* hpath.el (hpath:texinfo-section-pattern): Added and used in hpath:to-markup-anchor to + jump to specific Texinfo sections. + +2019-06-19 Bob Weiner <r...@gnu.org> + +* man/hyperbole.texi (Referent Display): Added doc of hpath:native-image-suffixes. + +* hpath.el (hpath:find-program): Changed to prioritize hpath:native-image-suffixes over + hpath:internal-display-alist over hpath:external-display-alist-macos instead of the + reverse. This prevents external viewers from being used when internal viewers are + also in effect. + +2019-06-18 Bob Weiner <r...@gnu.org> + +* hibtypes.el (grep-msg): Allowed for null char in place of first colon in colored grep output lines. + +2019-06-17 Bob Weiner <r...@gnu.org> + +* hactypes.el (link-to-gbut): Added. + hui.el (hui:link-possible-types): Added link-to-gbut. + +2019-06-16 Bob Weiner <r...@gnu.org> + +* hyrolo.el: Replaced buffer-substring-no-properties with match-string-no-properties where possible. + (hyrolo-entry-regexp): Changed to require whitespace following the entry prefix. + (hyrolo-entry-group-number): Added. + +2019-06-12 Bob Weiner <r...@gnu.org> + +* hib-kbd.el (kbd-key): Fixed preceding character test to not depend on the buffer's syntax table, + potentially missing kbd-key ibuts, notably ones using the universal argument. + +* hbut.el (ibut:at-type-p): Added to test if point is on a specific type of implicit button. + +* hib-kbd.el (kbd-key:normalize): Removed aggregation of C-u arguments into something like: C-u(16) + as this no longer works in current Emacs and causes an error. Now this just stays as "C-u C-u". + +2019-06-11 Bob Weiner <r...@gnu.org> + +* hypb.el (hypb:format-quote): Modified to return non-string args as is rather than ignoring them so + this can be used across any argument set. Used in hypb:error. + +2019-06-10 Bob Weiner <r...@gnu.org> + +* htz.el (htz:date-parse): Fixed bug, missing seconds in format 4 leading to invalid time strings saved + on MSWindows machines (and maybe more). Allow for this in style 5 which is how Hyperbole stores dates. + (htz:time-make-string): Chop off any spurious digits at the right. + +* hactypes.el (link-to-ibut): Added. + hui.el (hui:link-possible-types): Added ibut:at-p call for link-to-ibut. + +2019-06-07 Bob Weiner <r...@gnu.org> + +* hibtypes.el (debugger-source): Added support for pytype package errors (close to Python pdb ones) + +2019-06-06 Bob Weiner <r...@gnu.org> + +* hpath.el (hpath:find): Removed file-relative-name from error calls + because does not work when current-directory and filename are on different + drives under Windows at least through Emacs 26. + (hpath:find): Fixed that default-directory was not set to current + button's location, so path was expanded relative to another + directory, notably in hpath:validate call. + +2019-06-05 Bob Weiner <r...@gnu.org> + +* hpath.el (hpath:is-p): Tightened remote-path check to prevent matches that end with :line-num or :col-num. + +2019-06-04 Bob Weiner <r...@gnu.org> + +* hactypes.el (annot-bib): Changed to find referent from the end of the buffer rather than beginning, + to avoid multiple earlier annot-bib buttons +* DEMO (Hyperbole Source Buttons): Changed example button from annot-bib to kbd-key. + +* kotl/kvspec.el (kvspec:hide-levels): Changed behavior so view updates to default level clipping when + 'l' is excluded from the viewspec. + +2019-06-02 Bob Weiner <r...@gnu.org> + +* kotl/kvspec.el (kvspec:lines-to-show): Changed behavior so view updates to default cell clipping when + 'c' is excluded from the viewspec. + +* kotl/kotl-mode.el (kotl-mode:show-all): Limited (kvspec:update t) call to interactive usage only. + When kotl-mode:show-all is called in kvspec:update-view, it doesn't overwrite the to be set viewspec. + +* kotl/kvspec.el (kvspec:show-lines-per-cell) + (kvspec:show-lines-this-cell): Fixed viewspec 'c0' to expand visible cells properly. + +2019-06-01 Bob Weiner <r...@gnu.org> + +* hibtypes.el (ipython_stack_frame): Added to handle ipython stack traces and exceptions. + +2019-05-30 Bob Weiner <r...@gnu.org> + +* hyperbole.el (hkey-maybe-global-set-key): Fix missing no-add argument + to hkey-global-set-key call. + +2019-05-26 Bob Weiner <r...@gnu.org> + +* hui-mouse.el (hkey-alist): For Python files, use derived-mode-p and add + support for helm-pydoc buffers. + +============================================================================== +V7.0.3a changes ^^^^: +============================================================================== + 2019-05-11 Bob Weiner <r...@gnu.org> * man/hyperbole.texi (External Viewers): Commented out reference to mailcap use diff --git a/DEMO b/DEMO index 1d3b4a1..22b9d51 100644 --- a/DEMO +++ b/DEMO @@ -816,8 +816,9 @@ displayed. Test this technique with a {C-x C-f} (find-file) and then a {?}. ** Hyperbole Source Buttons -If you ask for help with the Assist Key or {C-u C-h A} from within the -[FSF 19] button, the first line of the help buffer will look like this: +If you ask for help with the Assist Key or {C-h A} from within this button, +{M-x dired-other-window RET ~ RET}, the first line of the help buffer will +look like this: @loc> "DEMO" diff --git a/HY-ANNOUNCE b/HY-ANNOUNCE index 7afa2a3..66feeb0 100644 --- a/HY-ANNOUNCE +++ b/HY-ANNOUNCE @@ -1,4 +1,211 @@ ---------------------------------------------------------------------- +7.0.3 Announcement +---------------------------------------------------------------------- +From: Bob Weiner <r...@gnu.org> +To: emacs-de...@gnu.org, gnu-emacs-sour...@gnu.org, emacs-tange...@gnu.org, hyperbole-us...@gnu.org, hyperbole-annou...@gnu.org +Subject: GNU Hyperbole 7.0.3: link your world quickly and easily +--text follows this line-- +======================================================================== +* Introduction +======================================================================== + +GNU Hyperbole 7.0.3 is released and ready for action. + +Hyperbole is an amazing hypertextual information management system +that installs quickly and easily as an Emacs package. It is part of +GNU Elpa, the Emacs Lisp Package Archive. + +Hyperbole interlinks all your working information within Emacs for +fast access and editing, not just within special modes. An hour +invested exploring Hyperbole's built-in interactive DEMO file will +save you hundreds of hours in your future work. + +7.0.3 is a significant release with a number of interesting +improvements. What's new in this release is described here: + + www.gnu.org/s/hyperbole/HY-NEWS.html + +Hyperbole is described here: + + www.gnu.org/s/hyperbole + +For use cases, see: + + www.gnu.org/s/hyperbole/HY-WHY.html + +For what users think about Hyperbole, see: + + https://www.gnu.org/s/hyperbole/hyperbole.html#user-quotes + +Hyperbole can supplement and extend Org-mode's capabilities. It adds +many features not found elsewhere in Emacs, including Org mode, see: + + www.emacswiki.org/emacs/Hyperbole + +Hyperbole includes its own easy-to-use hypertextual buttons and links +that can be created without the need for any markup language. + +Hyperbole has an interactive demo to introduce you to its features as +well as a detailed reference manual, as explained here: + + https://www.gnu.org/s/hyperbole/hyperbole.html#invocation-and-doc + +======================================================================== +* Quick Reasons to Try Hyperbole +======================================================================== + +It contains: + +- the most flexible and easy-to-use hyperbuttons available, including + implicit buttons automatically recognized by context, e.g. stack + trace source line references. + +- the only Emacs outliner with full legal item numbering, + e.g. 1.4.2.6, and automatic permanent hyperlink anchors for every + item + +- the only free-form contact manager with full-text search for Emacs + +- rapid and precise window, frame and buffer placement on screen + +- an extensive menu of typed web searches, e.g. dictionary, wikipedia + and stackoverflow, plus convenient, fast file and line finding + functions + +- immediate execution of a series of key presses just by typing them + out. For example, a M-RETURN press on: {C-x C-b C-s scratch RET + C-a} will find the first buffer menu item that contains 'scratch'; + then leave point at the beginning of its line. Build interactive + tutorials with this. + + +======================================================================== +* The Magic of Implicit Buttons and the Action Key +======================================================================== + +For near instant gratification, try Hyperbole's 'implicit button' +capabilities (hyper-buttons that Hyperbole gives you for free by +recognizing all types of references embedded within text such as +pathnames or error message lines). Below are more complex examples to +show the power; simpler ones can be found within the Hyperbole DEMO +file. + +Implicit buttons are activated by pressing the Action Key, M-RETURN. +Once Hyperbole is loaded in your Emacs, pressing M-RETURN on any of +these examples *in virtually any buffer* will display the associated +referent in a chosen window or frame, handling all variable +substitution and full path resolution: + + "find-func.el" Find this file whether gzipped or not + in the Emacs Lisp load-path + + "${hyperb:dir}/HY-NEWS" Resolve variable, show Hyperbole news + + "${PATH}/umask" Display a script somewhere in multi-dir PATH + + "${hyperb:dir}/DEMO#Hyperbole Menus" Org mode outline, Markdown, and HTML # refs + + "(hyperbole)Menus" Texinfo and Info node links + + "c:/Users", "c:\Users", "/C/Users", "/c/Users", and "/mnt/c/Users" + On Windows and Windows Subsystem for Linux, + Hyperbole recognizes all of these as the + same path and can translate between Windows + and POSIX path formats in both directions + +Git Links: + git#branches List branches in current repo/project + git#commits List and browse commits for current project + git#tags List tags in current project + + git#/hyperbole From any buffer, dired on the top + directory of the local hyperbole + project + + git#/hyperbole/55a1f0 or From any buffer, display hyperbole + git#hyperbole/55a1f0 local git commit diff + + +Github Links: + gh@rswgnu Display user's home page & projects + + github#rswgnu/hyperbole Display user's project + gh#rswgnu/helm/global_mouse Display user project's branch + gh#rswgnu/hyperbole/55a1f0 Display user project's commit diff + +Gitlab Links: + gitlab@seriyalexandrov Display user's home page + gl#gitlab-org/gitlab-ce/activity Summarize user's project activity + gl#gitlab-org/gitlab-ce/analytics Display user project's cycle_analytics + gl#gitlab-org/gitlab-ce/boards Display user project's kanban-type issue boards + +Once you set the default user and project variables, you can leave them off any reference links: + + (setq hibtypes-gitlab-default-user "gitlab-org") + (setq hibtypes-gitlab-default-project "gitlab-ce") + + gl#issues or gl#list Display default project's issue list + gl#labels Display default project's issue categories + gl#members Display default project's staff list + gl#contributors Show contributor push frequency charts + gl#merge_requests or gl#pulls Display default project's pull requests + gl#milestones Display default project's milestones status + gl#pages Display default project's web pages + gl#snippets Project snippets, diffs and text with discussion + gl#groups List all available groups of projects + gl#projects List all available projects + + gl#milestone=38 Show a specific project milestone + gl#snippet/1689487 Show a specific project snippet + +Even useful social media links: + tw#travel or twitter#travel Display twitter hashtag matches + fb#technology Display facebook hashtag matches + +Hyperbole uses simple prefix characters with paths to make them executable: + "!/bin/date" Execute as a non-windowed program within a shell + "&/opt/X11/bin/xeyes" Execute as a windowed program; + "-find-func.el" Load/execute this Emacs Lisp library + + File "/usr/lib/python3.7/ast.py", line 37, in parse + Jump to error/stack trace source + + "/ftp:anonym...@ftp.gnu.org:" Tramp remote paths + + +======================================================================== +* Try It - Installs or Uninstalls in a Minute +======================================================================== + +Hyperbole lets you concentrate more on your work. Then as you grow +with it across time, it helps speed your work across weeks and months. +It installs in about a minute and can be uninstalled even faster if +ever need be. Give it a try. + +Hyperbole can boost your day-to-day productivity with Emacs and +your ability to manage information stored across many different +machines on the internet. + +Hyperbole can be installed like any other package with the Emacs +package manager: + + {M-x list-packages RET C-s hyperbole RET i x y} + +Then to invoke its menu: + + {C-h h} or {M-x hyperbole RET} + +The best way to get a feel for many of its capabilities is to +invoke the interactive DEMO and explore sections of interest: + + {C-h h d d} + +Enjoy, + +The Hyperbole Team + + +---------------------------------------------------------------------- 7.0.2 Announcement ---------------------------------------------------------------------- From: Bob Weiner <r...@gnu.org> diff --git a/HY-NEWS b/HY-NEWS index 61e138c..0429549 100644 --- a/HY-NEWS +++ b/HY-NEWS @@ -887,7 +887,7 @@ are new in 2016 and you should look through them all. Implicit-Button menu. - On the Hyperbole Customize/Change-Key-Bindings menubar menu, renamed - these entries and added Mark-Think-Key. Similar updates done to the + these entries and added Mark-Thing-Key. Similar updates done to the minibuffer menu. MOUSE AND SMART KEY SUPPORT @@ -906,7 +906,7 @@ are new in 2016 and you should look through them all. help mode so you can page through it with SPC and DEL keys and then quit from it with {q}. - - A click of the Action Mouse Key within an inactive minibuffer menu + - A click of the Action Mouse Key within an inactive minibuffer window displays the Hyperbole minibuffer menu, allowing you to invoke menu entries with the mouse. A click of the Assist Key in the same place displays the buffer, window and frame jump menu just as does a click @@ -1008,13 +1008,13 @@ are new in 2016 and you should look through them all. - Added missing {C-c C-i}/{C-c TAB} binding mentioned in the EXAMPLE.kotl file; sets cell attributes. - - {C=t} Transpose characters - Added error checks at the beginning of cells + - {C-t} Transpose characters - Added error checks at the beginning of cells and end of lines for times when there are not 2 chars to transpose. ROLO - Improved {M-s} interactive string searching for rolo match buffer strings. - Made {C-u M-s} to a regexp search for rolo match buffer strings. + Made {C-u M-s} do a regexp search for rolo match buffer strings. - Documented the {l} hyrolo-locate command in the Hyperbole manual. @@ -1211,8 +1211,8 @@ are new in 2016 and you should look through them all. INSTALLATION - - Installation is greatly simplified. A single emacs initialization line - of the form: + - Hyperbole initialization is greatly simplified. A single "~/.emacs" + line of the form: (require 'hyperbole (expand-file-name "hyperbole" "<HYPERBOLE-DIR>/") @@ -1266,7 +1266,7 @@ are new in 2016 and you should look through them all. now begin with 'K'. Some used to start with 'O'. To edit the example Koutline, use {C-h h k e}. - - {C-c C-a} - Show-all, expand all cells nihe current view. + - {C-c C-a} - Show-all, expand all cells in the current view. {C-c C-o} - Overview, show only first line of outline cells. {C-c C-t} - Top-level, hide all cells below level 1 and show only the first line of each level 1 cell. diff --git a/hactypes.el b/hactypes.el index bfe03fc..d227faa 100644 --- a/hactypes.el +++ b/hactypes.el @@ -29,8 +29,8 @@ (key-regexp (concat "^[*]*[ \t]*\\\[" (ebut:key-to-label key) "\\\]")) citation) (if (save-excursion - (goto-char (point-min)) - (setq citation (re-search-forward key-regexp nil t))) + (goto-char (point-max)) + (setq citation (re-search-backward key-regexp nil t))) (progn (hpath:display-buffer (current-buffer)) (goto-char citation) (beginning-of-line)) @@ -272,11 +272,12 @@ Use `link-to-file' instead for a permanent link." nil nil nil 'ebut))) (beep)) (ebut:label-to-key but-lbl))))) - (or (called-interactively-p 'interactive) - (setq key-file (hpath:validate (hpath:substitute-value key-file)))) + (unless (called-interactively-p 'interactive) + (setq key-file (hpath:validate (hpath:substitute-value key-file)))) (let ((but (ebut:get key (find-file-noselect key-file)))) (if but (hbut:act but) - (hypb:error "(link-to-ebut): No button `%s' in `%s'." (ebut:key-to-label key) + (hypb:error "(link-to-ebut): No button `%s' in `%s'." + (ebut:key-to-label key) key-file)))) (defact link-to-elisp-doc (symbol) @@ -351,6 +352,24 @@ the window." (hpath:find-line path line-num)) (move-to-column column-num))) +(defact link-to-gbut (key) + "Performs action given by an existing global button, specified by KEY." + (interactive + (let ((gbut-file (hpath:validate (hpath:substitute-value gbut:file))) + but-lbl) + (if (not (file-readable-p gbut-file)) + (hypb:error "(link-to-gbut): You cannot read `%s'." gbut-file) + (list (progn + (find-file-noselect gbut-file) + (while (string-equal "" (setq but-lbl + (hargs:read-match + "Global button to link to: " + (mapcar 'list (gbut:label-list)) + nil t nil 'gbut))) + (beep)) + (hbut:label-to-key but-lbl)))))) + (gbut:act (hbut:key-to-label key))) + (defact link-to-Info-index-item (index-item) "Displays an Info index INDEX-ITEM cross-reference. INDEX-ITEM must be a string of the form \"(filename)item-name\". During @@ -373,6 +392,30 @@ available. Filename may be given without the .info suffix." (id-info string) (hypb:error "(link-to-Info-node): Invalid Info node: `%s'" string))) +(defact link-to-ibut (key-file key &optional point) + "Performs action given by an implicit button, specified by KEY-FILE, KEY and optional POINT. +When creating the button, point must be on the implicit button to which to link +and its buffer must have a file attached." + (interactive + (let ((ibut-key (ibut:at-p t))) + (if (and ibut-key buffer-file-name) + (list buffer-file-name ibut-key (point)) + (list nil nil nil)))) + (or (called-interactively-p 'interactive) + (setq key-file (hpath:validate (hpath:substitute-value key-file)))) + (let (but) + (if (and key-file + (save-excursion + (save-restriction + (find-file-noselect key-file) + (widen) + (if (integerp point) (goto-char (min point (point-max)))) + (setq but (ibut:to key))))) + (hbut:act but) + (hypb:error "(link-to-ibut): No button `%s' in `%s'." + (ibut:key-to-label key) + key-file)))) + (defact link-to-kcell (file cell-ref) "Displays FILE with kcell given by CELL-REF at window top. See documentation for `kcell:ref-to-id' for valid cell-ref formats. diff --git a/hargs.el b/hargs.el index 696cdab..e5ea221 100644 --- a/hargs.el +++ b/hargs.el @@ -320,7 +320,10 @@ Handles all of the interactive argument types that `hargs:iform-read' does." (t 0))))) ((hargs:completion t)) ((eq hargs:reading-p 'ebut) (ebut:label-p 'as-label)) - ((ebut:label-p) nil) + ((eq hargs:reading-p 'gbut) + (when (eq (current-buffer) (get-file-buffer gbut:file)) + (hbut:label-p 'as-label))) + ((hbut:label-p) nil) ((eq hargs:reading-p 'file) (cond ((derived-mode-p 'dired-mode) (let ((file (dired-get-filename nil t))) @@ -517,7 +520,7 @@ See also documentation for `interactive'." ;; `@' means select window of last mouse event. ;; ;; `^' means activate/deactivate mark depending on invocation thru shift translation - ;; See `this-command-keys-shift-translated' for somewhat of an explanation. + ;; See `this-command-keys-shift-translated' for an explanation. ;; ;; `_' means keep region in same state (active or inactive) ;; after this command. (XEmacs only.) diff --git a/hbut.el b/hbut.el index e4104f9..cc71510 100644 --- a/hbut.el +++ b/hbut.el @@ -33,8 +33,7 @@ Nil disables saving.") (defconst ebut:max-len 100 "Maximum length of a hyper-button label.") - -(defun ebut:act (label) +(defun ebut:act (label) "Activates Hyperbole explicit button with LABEL from the current buffer." (interactive (list (hargs:read-match "Activate explicit button labeled: " (ebut:alist) @@ -46,7 +45,7 @@ Nil disables saving.") (error "(ebut:act): No explicit button labeled: %s" label)))) (defun ebut:alist (&optional file) - "Returns alist with each element a list containing a button label. + "Returns alist with each element a list containing an explicit button label. For use as a completion table. Gets labels from optional FILE or current buffer." (mapcar 'list (ebut:list file))) @@ -57,7 +56,8 @@ Assumes point is within first line of button label, if at all. Optional START-DELIM and END-DELIM are strings that override default button delimiters." (let ((key (ebut:label-p nil start-delim end-delim))) - (and key (ebut:get key)))) + (when key + (ebut:get key)))) (defun ebut:create (&optional but-sym) "Creates Hyperbole explicit button based on optional BUT-SYM. @@ -95,60 +95,58 @@ Returns entry deleted (a list of attribute values) or nil." (defun ebut:get (&optional lbl-key buffer key-src) "Returns explicit Hyperbole button symbol given by LBL-KEY and BUFFER. -KEY-SRC is given when retrieving global buttons and is full source pathname. +KEY-SRC is given when retrieving global buttons and is the full source pathname. + Retrieves button data, converts into a button object and returns a symbol which references the button. -All arguments are optional. When none are given, returns symbol for -button that point is within or nil. BUFFER defaults to the current +All arguments are optional. When none are given, returns a symbol for +the button that point is within or nil. BUFFER defaults to the current buffer." (hattr:clear 'hbut:current) (save-excursion (let ((key-file) (key-dir) (but-data) (actype)) - (or lbl-key (setq lbl-key (ebut:label-p))) - (if buffer - (if (bufferp buffer) (set-buffer buffer) + (unless lbl-key + (setq lbl-key (ebut:label-p))) + (when buffer + (if (bufferp buffer) + (set-buffer buffer) (error "(ebut:get): Invalid buffer argument: %s" buffer))) - (if key-src - nil - (if (equal lbl-key (ebut:label-p)) - nil + (when (not key-src) + (when (not (equal lbl-key (ebut:label-p))) (goto-char (point-min)) (ebut:next-occurrence lbl-key)) - (if (setq key-src (ebut:key-src 'full)) - ;; `ebut:key-src' sets current buffer to key-src buffer. - (setq buffer (current-buffer))) - ) - (if (and (stringp lbl-key) key-src) - (progn - (if (stringp key-src) - (setq key-dir (file-name-directory key-src) - key-file (file-name-nondirectory key-src))) - (setq but-data (and key-src - (hbdata:get-entry lbl-key (or key-file key-src) - key-dir))) - (if (null but-data) - nil - (hattr:set 'hbut:current 'lbl-key lbl-key) - (hattr:set 'hbut:current 'loc key-src) - (hattr:set 'hbut:current 'categ 'explicit) - (hattr:set 'hbut:current 'action nil) - (hattr:set 'hbut:current 'actype - (intern (setq actype (hbdata:actype but-data)))) - ;; Hyperbole V1 referent compatibility - (if (= (length actype) 2) - (hattr:set 'hbut:current 'referent - (hbdata:referent but-data))) - (hattr:set 'hbut:current 'args (hbdata:args but-data)) - (hattr:set 'hbut:current 'creator (hbdata:creator but-data)) - (hattr:set 'hbut:current - 'create-time (hbdata:create-time but-data)) - (hattr:set 'hbut:current - 'modifier (hbdata:modifier but-data)) - (hattr:set 'hbut:current - 'mod-time (hbdata:mod-time but-data)) - 'hbut:current) - ))))) + (when (setq key-src (ebut:key-src 'full)) + ;; `ebut:key-src' sets current buffer to key-src buffer. + (setq buffer (current-buffer)))) + (when (and (stringp lbl-key) key-src) + (when (stringp key-src) + (setq key-dir (file-name-directory key-src) + key-file (file-name-nondirectory key-src))) + (setq but-data (and key-src + (hbdata:get-entry lbl-key (or key-file key-src) + key-dir))) + (when but-data + (hattr:set 'hbut:current 'lbl-key lbl-key) + (hattr:set 'hbut:current 'loc key-src) + (hattr:set 'hbut:current 'categ 'explicit) + (hattr:set 'hbut:current 'action nil) + (hattr:set 'hbut:current 'actype + (intern (setq actype (hbdata:actype but-data)))) + ;; Hyperbole V1 referent compatibility + (if (= (length actype) 2) + + (hattr:set 'hbut:current 'referent + (hbdata:referent but-data))) + (hattr:set 'hbut:current 'args (hbdata:args but-data)) + (hattr:set 'hbut:current 'creator (hbdata:creator but-data)) + (hattr:set 'hbut:current + 'create-time (hbdata:create-time but-data)) + (hattr:set 'hbut:current + 'modifier (hbdata:modifier but-data)) + (hattr:set 'hbut:current + 'mod-time (hbdata:mod-time but-data)) + 'hbut:current))))) (defun ebut:is-p (object) "Returns non-nil if OBJECT denotes an explicit Hyperbole button." @@ -174,21 +172,17 @@ With optional FULL when source is a pathname, the full pathname is returned." ((save-excursion (and (re-search-backward "^[a-z]*make[^a-z]+\\(Entering\\|Leaving\\) directory `\\([^']+\\)'" nil t) - (string-equal "Entering" - (buffer-substring (match-beginning 1) - (match-end 1))))) + (string-equal "Entering" (match-string 1)))) (let ((limit (match-end 2)) ;; Latest working directory that `make' reported - (wd (buffer-substring (match-beginning 2) - (match-end 2))) + (wd (match-string 2)) cd) ;; But another cd or pushd command may have been issued. ;; Return the closest directory from the make output. (if (re-search-backward "\\<\\(cd\\|pushd\\)\\s +[\"\']?\\([^;\"\'\n\r\^L\\]+\\)" limit t) - (progn (setq cd (buffer-substring (match-beginning 2) - (match-end 2))) + (progn (setq cd (match-string 2)) ;; Eliminate any trailing whitespace. (setq cd (substring cd 0 (string-match "\\s +\\'" cd))) @@ -209,18 +203,22 @@ With optional FULL when source is a pathname, the full pathname is returned." (= (point) (point-min)))) (hbut:source full))))) (t (current-buffer))))) - (cond ((null src) nil) - ((bufferp src) - (set-buffer src) - src) - ((file-directory-p src) - (file-name-as-directory src)) - ((file-readable-p src) - (set-buffer (find-file-noselect src)) - src) - ((file-readable-p (setq src (hpath:symlink-referent src))) - (set-buffer (find-file-noselect src)) - src)))) + (ebut:key-src-set-buffer src))) + +(defun ebut:key-src-set-buffer (src) + "Set buffer to SRC, a buffer, file, directory or symlink and return SRC or nil if invalid." + (cond ((null src) nil) + ((bufferp src) + (set-buffer src) + src) + ((file-directory-p src) + (file-name-as-directory src)) + ((file-readable-p src) + (set-buffer (find-file-noselect src)) + src) + ((file-readable-p (setq src (hpath:symlink-referent src))) + (set-buffer (find-file-noselect src)) + src))) (defun ebut:key-src-fmt () "Returns unformatted filename associated with formatted current buffer. @@ -256,35 +254,34 @@ represent the output of particular document formatters." lbl))) (defun ebut:label-p (&optional as-label start-delim end-delim pos-flag two-lines-flag) - "Returns key for Hyperbole button label that point is within. -Returns nil if not within a label. Assumes point is within first line - of button label, if at all. -All following arguments are optional. If AS-LABEL is non-nil, label -is returned rather than the key derived from the label. START-DELIM -and END-DELIM are strings that override default button delimiters. -With POS-FLAG non-nil, returns list of label-or-key, -but-start-position, but-end-position. Positions include delimiters. -With TWO-LINES-FLAG non-nil, constrains label search to two lines." + "Returns key for the Hyperbole explicit button label that point is within, else nil. +Assumes point is within the first line of any button label. All +following arguments are optional. If AS-LABEL is non-nil, label +is returned rather than the key derived from the label. +START-DELIM and END-DELIM are strings that override default +button delimiters. With POS-FLAG non-nil, returns list of +label-or-key, but-start-position, but-end-position. Positions +include delimiters. With TWO-LINES-FLAG non-nil, constrains +label search to two lines." (let ((opoint (point)) - (npoint) (quoted "\\(^\\|[^\\{]\\)") - (start) (ebut:max-len ebut:max-len) - lbl-key end but-start but-end) - (or start-delim (setq start-delim ebut:start)) - (or end-delim (setq end-delim ebut:end)) - (setq npoint (+ opoint (length start-delim))) - ;; Ensure label is not blank + npoint start lbl-key end but-start but-end start-regexp end-regexp) + (unless start-delim (setq start-delim ebut:start)) + (unless end-delim (setq end-delim ebut:end)) + (setq start-regexp (regexp-quote start-delim) + end-regexp (regexp-quote end-delim) + npoint (+ opoint (length start-delim))) + ;; Ensure label is not blank and point is within matching delimiters (save-excursion - (beginning-of-line) + (forward-line 0) (while (and (progn - (while (re-search-forward - (concat quoted (regexp-quote start-delim)) - npoint t) + (while (and (< (point) npoint) + (re-search-forward (concat quoted start-regexp) npoint t)) (setq start t)) start) - (re-search-forward (concat "[^\\{]" (regexp-quote end-delim)) - npoint t)) + (< (point) opoint) + (re-search-forward (concat "[^\\{]" end-regexp) opoint t)) (setq start nil)) (when start (setq start (point) @@ -302,49 +299,24 @@ With TWO-LINES-FLAG non-nil, constrains label search to two lines." (forward-line 2) (setq ebut:max-len (- (point) start)))) (and (< (point) (+ start ebut:max-len)) - (re-search-forward (concat quoted (regexp-quote end-delim)) - (+ start ebut:max-len) t) + (re-search-forward (concat quoted end-regexp) (+ start ebut:max-len) t) (setq but-end (point) end (- (point) (length end-delim)) - lbl-key (ebut:label-to-key (buffer-substring start end))) + lbl-key (ebut:label-to-key (buffer-substring-no-properties start end))) (cond (pos-flag (if as-label (list (ebut:key-to-label lbl-key) but-start but-end) (list lbl-key but-start but-end))) (t (if as-label (ebut:key-to-label lbl-key) lbl-key)))))))) -(defun ebut:label-regexp (lbl-key &optional no-delim) - "Unnormalizes LBL-KEY. Returns regular expr matching delimited but label. -Optional NO-DELIM leaves off delimiters and leading and trailing space." - (if lbl-key - (let* ((pos 0) - (len (length lbl-key)) - (c) - (sep0 "[ \t\n\r]*") - (sep "[ \t\n\r]+") - (regexp (if no-delim "" (concat (regexp-quote ebut:start) sep0))) - (case-fold-search)) - (while (< pos len) - (setq c (aref lbl-key pos) - regexp (concat regexp - (if (eq c ?_) - (if (or (= (1+ pos) len) - (not (eq (aref lbl-key (1+ pos)) ?_))) - sep - (setq pos (1+ pos)) - "_") - (regexp-quote (char-to-string c)))) - pos (1+ pos))) - (if no-delim regexp - (setq regexp (concat regexp sep0 (regexp-quote ebut:end))))))) +(defalias 'ebut:label-regexp 'hbut:label-regexp) (defun ebut:label-to-key (label) "Normalizes LABEL for use as a Hyperbole button key and returns key. Eliminates any fill prefix in the middle of the label, replaces `_' with `__', removes leading and trailing whitespace and replaces each other whitespace sequence with `_'." - (if (null label) - nil + (when label (setq label (hbut:fill-prefix-remove label) ;; Remove leading and trailing space. label (hypb:replace-match-string "\\`[ \t\n\r]+\\|[ \t\n\r]+\\'" @@ -356,31 +328,30 @@ whitespace sequence with `_'." "Returns list of button labels from given FILE or current buffer. Removes duplicate labels if optional LOC-P is omitted. With LOC-P, returns list of elements (label start end) where start and end are the buffer -positions at which the starting button delimiter begins and ends." +positions at which the button delimiter begins and ends." (interactive) (setq file (if file (and (file-exists-p file) (find-file-noselect file)) (current-buffer))) - (if file - (progn - (set-buffer file) - (let ((buts (ebut:map (if loc-p - (lambda (lbl start end) - ;; Normalize label spacing - (list (ebut:key-to-label - (ebut:label-to-key lbl)) - start end)) - (lambda (lbl start end) - ;; Normalize label spacing - (ebut:key-to-label - (ebut:label-to-key lbl))))))) - (if loc-p buts (if buts (apply #'set:create buts))))))) - -(defalias 'map-ebut 'ebut:map) + (when file + (set-buffer file) + (let ((buts (ebut:map (if loc-p + (lambda (lbl start end) + ;; Normalize label spacing + (list (ebut:key-to-label (ebut:label-to-key lbl)) + start end)) + (lambda (lbl start end) + ;; Normalize label spacing + (ebut:key-to-label (ebut:label-to-key lbl))))))) + (if loc-p buts (if buts (apply #'set:create buts)))))) + +(defalias 'map-ebut 'ebut:map) (defun ebut:map (but-func &optional start-delim end-delim regexp-match include-delims) "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM. +START-DELIM defaults to ebut:start; END-DELIM defaults to ebut:end. If REGEXP-MATCH is non-nil, only buttons which match this argument are considered. + Maps over portion of buffer visible under any current restriction. BUT-FUNC must take precisely three arguments: the button label, the start position of the delimited button label and its end position (positions @@ -405,12 +376,10 @@ expression which matches an entire button string." nil t) (setq start (match-beginning include-delims) end (match-end include-delims) - but (buffer-substring (match-beginning 0) (match-end 0)) - lbl (buffer-substring (match-beginning 1) (match-end 1)) + but (match-string 0) + lbl (match-string 1) ;; If within a programming language buffer, ignore matches outside comments. - ignore (and (derived-mode-p 'prog-mode) - ;; Match is outside of a programming language comment - (not (nth 4 (syntax-ppss))))) + ignore (hbut:outside-comment-p)) (save-excursion (goto-char start) ;; Ignore matches with quoted delimiters. @@ -638,9 +607,9 @@ Inserts INSTANCE-STR after END, before ending delimiter." "\\)" match-part (regexp-quote ebut:end))) (defconst ebut:start "<(" - "String matching the start of a hyper-button.") + "String matching the start of a Hyperbole explicit hyper-button.") (defconst ebut:end ")>" - "String matching the end of a hyper-button.") + "String matching the end of a Hyperbole explicit hyper-button.") (defconst ebut:instance-sep ":" "String of one character, separates an ebut label from its instance num.") @@ -648,25 +617,36 @@ Inserts INSTANCE-STR after END, before ending delimiter." ;;; gbut class - Global Hyperbole buttons - activated by typing label name ;;; ======================================================================== -(defvar gbut:file (expand-file-name hbmap:filename hbmap:dir-user) +(defvar gbut:file (expand-file-name hbmap:filename hbmap:dir-user) "File that stores globally accessible Hyperbole buttons, accessed by name.") -(defun gbut:act (label) +(defun gbut:act (label) "Activates Hyperbole global button with LABEL." (interactive (list (hargs:read-match "Activate global button labeled: " (mapcar 'list (gbut:label-list)) - nil t nil 'ebut))) + nil t nil 'gbut))) (cond ((null label) (error "(gbut:act): You have not created any global buttons")) ((equal label "") (error "(gbut:act): Please try again and type ? for a list of existing global button names")) (t (let* ((lbl-key (hbut:label-to-key label)) - (but (ebut:get lbl-key nil gbut:file))) + (but (gbut:get lbl-key))) (if but (hbut:act but) (error "(gbut:act): No global button labeled: %s" label)))))) -(defun gbut:help (label) +(defun gbut:get (&optional lbl-key) + "Returns global Hyperbole button symbol given by optional LBL-KEY if found in gbut:file. + +Retrieves any button data, converts into a button object and returns a symbol +which references the button. + +All arguments are optional. When none are given, returns a symbol for +the button that point is within or nil." + (or (ebut:get lbl-key nil gbut:file) + (ibut:get lbl-key nil gbut:file))) + +(defun gbut:help (label) "Displays help for Hyperbole global button with LABEL." (interactive (list (hargs:read-match "Report on global button labeled: " (mapcar 'list (gbut:label-list)) @@ -677,18 +657,22 @@ Inserts INSTANCE-STR after END, before ending delimiter." (hbut:report but) (error "(gbut:help): No global button labeled: %s" label)))) -(defun gbut:label-list () +(defun gbut:label-list () "Returns list of global button labels." (mapcar 'hbut:key-to-label (gbut:key-list))) ;;; ------------------------------------------------------------------------ -(defun gbut:key-list () +(defun gbut:key-list () "Returns list of global button label keys." + (nconc (gbut:ebut-key-list) (gbut:ibut-key-list))) + +(defun gbut:ebut-key-list () + "Returns a list of explicit button label keys from the global button file." (save-excursion (if (hbdata:to-entry-buf gbut:file) - (let ((gbuts)) + (let (gbuts) (save-restriction - (narrow-to-region (point) (if (search-forward "\^L" nil t) + (narrow-to-region (point) (if (search-forward "\f" nil t) (point) (point-max))) (goto-char (point-min)) (condition-case () @@ -696,6 +680,15 @@ Inserts INSTANCE-STR after END, before ending delimiter." (error nil)) gbuts))))) +(defun gbut:ibut-key-list () + "Returns a list of implicit button label keys from the global button file." + (when (file-readable-p gbut:file) + (save-excursion + (set-buffer (find-file-noselect gbut:file)) + (save-restriction + (widen) + (ibut:label-map #'(lambda (label start end) (ibut:label-to-key label))))))) + ;;; ======================================================================== ;;; hattr class ;;; ======================================================================== @@ -807,7 +800,7 @@ Suitable for use as part of `write-file-functions'." "Sets OBJ-SYMBOL's attribute ATTR-SYMBOL to ATTR-VALUE and returns ATR-VALUE." (put obj-symbol attr-symbol attr-value)) -(defalias 'hattr:summarize 'hattr:report) +(defalias 'hattr:summarize 'hattr:report) (defvar hattr:filename (if hyperb:microsoft-os-p "_hypb" ".hypb") @@ -918,8 +911,9 @@ Ignores email-related buffers." "Returns non-nil if object denotes a Hyperbole button." (and (symbolp object) (hattr:get object 'categ))) -(defalias 'hbut:key-src 'ebut:key-src) -(defalias 'hbut:key-to-label 'ebut:key-to-label) +(defalias 'hbut:key-src 'ebut:key-src) +(defalias 'hbut:key-src-set-buffer 'ebut:key-src-set-buffer) +(defalias 'hbut:key-to-label 'ebut:key-to-label) (defun hbut:label (hbut) "Returns the label for Hyperbole button symbol HBUT." @@ -928,8 +922,60 @@ Ignores email-related buffers." (error "(hbut:label): Argument is not a Hyperbole button symbol, `%s'" hbut))) -(defalias 'hbut:label-p 'ebut:label-p) -(defalias 'hbut:label-to-key 'ebut:label-to-key) +(defun hbut:label-p (&optional as-label start-delim end-delim pos-flag two-lines-flag) + "Returns key for the Hyperbole button label that point is within, else nil. +Assumes point is within the first line of any button label. All +following arguments are optional. If AS-LABEL is non-nil, label +is returned rather than the key derived from the label. +START-DELIM and END-DELIM are strings that override default +button delimiters. With POS-FLAG non-nil, returns list of +label-or-key, but-start-position, but-end-position. Positions +include delimiters. With TWO-LINES-FLAG non-nil, constrains +label search to two lines." + (if (and start-delim end-delim) + (ebut:label-p as-label start-delim end-delim pos-flag two-lines-flag) + (or (ebut:label-p as-label start-delim end-delim pos-flag two-lines-flag) + (ibut:label-p as-label start-delim end-delim pos-flag two-lines-flag)))) + +(defun hbut:label-regexp (lbl-key &optional no-delim start-delim end-delim) + "Unnormalizes LBL-KEY. Returns regular expr matching delimited button label. +Optional NO-DELIM leaves off delimiters and leading and trailing space. +Optional START-DELIM and END-DELIM are added around the returned +label; these default to `ebut:start' and `ebut:end'." + (when lbl-key + (let* ((pos 0) + (len (length lbl-key)) + (c) + (sep0 "[ \t\n\r]*") + (sep "[ \t\n\r]+") + (regexp (if no-delim "" (concat (regexp-quote (or start-delim ebut:start)) sep0))) + (case-fold-search)) + (while (< pos len) + (setq c (aref lbl-key pos) + regexp (concat regexp + (if (eq c ?_) + (if (or (= (1+ pos) len) + (not (eq (aref lbl-key (1+ pos)) ?_))) + sep + (setq pos (1+ pos)) + "_") + (regexp-quote (char-to-string c)))) + pos (1+ pos))) + (if no-delim + regexp + (setq regexp (concat regexp sep0 (regexp-quote (or end-delim ebut:end)))))))) + + +(defalias 'hbut:label-to-key 'ebut:label-to-key) + +(defalias 'hbut:map 'ebut:map) + +(defun hbut:outside-comment-p () + "Returns t if within a programming language buffer and prior regexp match is outside a comment, else nil." + (when (and (derived-mode-p 'prog-mode) + (not (eq major-mode 'lisp-interaction-mode))) + ;; Match is outside of a programming language comment + (not (nth 4 (syntax-ppss))))) (defun hbut:report (&optional arg) "Pretty prints the attributes of a button or buttons. @@ -1003,17 +1049,17 @@ Returns number of buttons reported on or nil if none." If a file, always returns a full path if optional FULL is non-nil." (goto-char (match-end 0)) (cond ((looking-at "#<buffer \"?\\([^\n\"]+\\)\"?>") - (get-buffer (buffer-substring (match-beginning 1) - (match-end 1)))) + (get-buffer (match-string 1))) ((looking-at "\".+\"") - (let* ((file (buffer-substring (1+ (match-beginning 0)) - (1- (match-end 0)))) + (let* ((file (buffer-substring-no-properties + (1+ (match-beginning 0)) + (1- (match-end 0)))) (absolute (file-name-absolute-p file))) (if (and full (not absolute)) (expand-file-name file default-directory) file))))) -(defalias 'hbut:summarize 'hbut:report) +(defalias 'hbut:summarize 'hbut:report) (defvar hbut:current nil "The currently selected Hyperbole button. Available to action routines.") @@ -1023,44 +1069,152 @@ If a file, always returns a full path if optional FULL is non-nil." This expression should be followed immediately by a file-name indicating the source file for the buttons in the menu, if any.") +(defun hbut:label-list () + "Returns list of current buffer's Hyperbole button labels." + (mapcar 'hbut:key-to-label (hbut:key-list))) + +;;; ------------------------------------------------------------------------ + +(defun hbut:key-list () + "Returns list of global button label keys." + (nconc (hbut:ebut-key-list) (hbut:ibut-key-list))) + +(defun hbut:ebut-key-list (&optional key-src) + "Returns a list of explicit button label keys from optional KEY-SRC or the current buffer." + (save-excursion + (if (hbdata:to-entry-buf (or key-src (buffer-file-name))) + (let (hbuts) + (save-restriction + (narrow-to-region (point) (if (search-forward "\f" nil t) + (point) (point-max))) + (goto-char (point-min)) + (condition-case () + (while (setq hbuts (cons (car (read (current-buffer))) hbuts))) + (error nil)) + hbuts))))) + +(defun hbut:ibut-key-list (&optional key-src) + "Returns a list of implicit button label keys from optional KEY-SRC or the current buffer." + (save-excursion + (when (hbut:key-src-set-buffer (or key-src (current-buffer))) + (save-restriction + (widen) + (ibut:label-map #'(lambda (label start end) (ibut:label-to-key label))))))) + ;;; ======================================================================== ;;; ibut class - Implicit Hyperbole Buttons ;;; ======================================================================== (defun ibut:at-p (&optional key-only) "Returns symbol for implicit button at point, else nil. -With optional KEY-ONLY, returns only the label key for button." - (let ((types (htype:category 'ibtypes)) - ;; Global var used in (hact) function, don't delete. - (hrule:action 'actype:identity) - (itype) - (args) - (is-type)) - (or key-only (hattr:clear 'hbut:current)) - (while (and (not is-type) types) - (setq itype (car types)) - (if (setq args (funcall itype)) - (setq is-type itype) - (setq types (cdr types)))) - (if is-type - (if key-only - (hattr:get 'hbut:current 'lbl-key) - (hattr:set 'hbut:current 'loc (save-excursion - (hbut:key-src 'full))) - (hattr:set 'hbut:current 'categ is-type) - (or (hattr:get 'hbut:current 'args) - (not (listp args)) - (progn - (hattr:set 'hbut:current 'actype - (or - ;; Hyperbole action type - (intern-soft (concat "actypes::" - (symbol-name (car args)))) - ;; Regular Emacs Lisp function symbol - (car args) - )) - (hattr:set 'hbut:current 'args (cdr args)))) - 'hbut:current)))) +Point may be on the implicit button or its optional preceding label. +With optional KEY-ONLY, returns only the label key for button. + +Any labeled implicit button must contain at least two characters, +excluding delimiters, not just one." + (let* ((opoint (point)) + (label-key-start-end (ibut:label-p nil nil nil t t)) + (lbl-key (car label-key-start-end))) + (unwind-protect + (when (not (hbut:outside-comment-p)) + ;; Skip past any optional label and separators + (when label-key-start-end + (goto-char (nth 2 label-key-start-end)) + (when (looking-at ibut:label-separator) + ;; Move past up to 2 possible characters of ibut + ;; delimiters; this prevents recognizing labeled, + ;; delimited ibuts of a single character but no one + ;; should need that. + (goto-char (min (+ 2 (match-end 0)) (point-max))))) + + ;; Check for an implicit button at current point, record its + ;; attributes and return a button symbol for it. + (let ((types (htype:category 'ibtypes)) + ;; Global var used in (hact) function, don't delete. + (hrule:action 'actype:identity) + (itype) + (args) + (is-type)) + (unless key-only + (hattr:clear 'hbut:current)) + (while (and (not is-type) types) + (setq itype (car types)) + (if (setq args (funcall itype)) + (setq is-type itype) + (setq types (cdr types)))) + (when is-type + (when lbl-key + (hattr:set 'hbut:current 'lbl-key lbl-key)) + (if key-only + (hattr:get 'hbut:current 'lbl-key) + (hattr:set 'hbut:current 'loc (save-excursion + (hbut:key-src 'full))) + (hattr:set 'hbut:current 'categ is-type) + (or (hattr:get 'hbut:current 'args) + (not (listp args)) + (progn + (hattr:set 'hbut:current 'actype + (or + ;; Hyperbole action type + (intern-soft (concat "actypes::" + (symbol-name (car args)))) + ;; Regular Emacs Lisp function symbol + (car args))) + (hattr:set 'hbut:current 'args (cdr args)))) + 'hbut:current)))) + (goto-char opoint)))) + +(defun ibut:at-type-p (ibut-type-symbol) + "Returns non-nil if point is on a button of type `ibut-type-symbol`. +Point must be on the button itself and not its label, if any. + +The return value is a list of the type's action type symbol and +associated arguments from the button." + (when (and ibut-type-symbol (symbolp ibut-type-symbol)) + (let ((type-name (symbol-name ibut-type-symbol))) + (unless (string-match "::" type-name) + (setq ibut-type-symbol (intern-soft (concat "ibtypes::" type-name)))) + (when ibut-type-symbol + (let ((types (htype:category 'ibtypes)) + ;; Global var used in (hact) function, don't delete. + (hrule:action 'actype:identity)) + (funcall ibut-type-symbol)))))) + +(defun ibut:get (&optional lbl-key buffer key-src) + "Returns implicit Hyperbole button symbol given by LBL-KEY and BUFFER. +KEY-SRC is given when retrieving global buttons and is the full source pathname. + +Retrieves button data, converts into a button object and returns a symbol +which references the button. + +All arguments are optional. When none are given, returns a +symbol for the button or button label that point is within or +nil. BUFFER defaults to the current buffer." + (hattr:clear 'hbut:current) + (save-excursion + (let ((key-file) (key-dir) (but-data) (actype)) + (unless lbl-key + (setq lbl-key (ibut:label-p nil nil nil nil t))) + (when buffer + (if (bufferp buffer) + (set-buffer buffer) + (error "(ibut:get): Invalid buffer argument: %s" buffer))) + (when (not key-src) + (when (not (equal lbl-key (ibut:label-p nil nil nil nil t))) + (goto-char (point-min)) + (ibut:next-occurrence lbl-key)) + (when (setq key-src (hbut:key-src 'full)) + ;; `hbut:key-src' sets current buffer to key-src buffer. + (setq buffer (current-buffer)))) + (when (and (stringp lbl-key) key-src) + (when (stringp key-src) + (setq key-dir (file-name-directory key-src) + key-file (file-name-nondirectory key-src))) + (set-buffer (find-file-noselect key-src)) + (goto-char (point-min)) + (ibut:next-occurrence lbl-key) + ;; Build and return button symbol with button properties + (ibut:at-p))))) (defun ibut:is-p (object) "Returns non-nil if object denotes an implicit Hyperbole button." @@ -1068,16 +1222,49 @@ With optional KEY-ONLY, returns only the label key for button." (let ((categ (hattr:get object 'categ))) (and categ (string-match "^ibtypes::" (symbol-name categ)))))) -(defun ibut:label-p () - "Returns key for Hyperbole implicit button label that point is on or nil." - (ibut:at-p 'key-only)) +(defun ibut:label-map (but-func &optional start-delim end-delim + regexp-match include-delims) + "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM. +START-DELIM defaults to ibut:label-start; END-DELIM defaults to ibut:label-end. +If REGEXP-MATCH is non-nil, only buttons which match this argument are +considered. + +Maps over portion of buffer visible under any current restriction. +BUT-FUNC must take precisely three arguments: the button label, the +start position of the delimited button label and its end position (positions +include delimiters when INCLUDE-DELIMS is non-nil). +If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular +expression which matches an entire button string." + (hbut:map but-func ibut:label-start ibut:label-end)) + +(defun ibut:label-p (&optional as-label start-delim end-delim pos-flag two-lines-flag) + "Returns key for the Hyperbole implicit button label that point is within, else nil. +This is an optional label that may precede an implicit button. +Use `ibut:at-p' instead to test if point is on either the +implicit button itself or the label. Assumes point is within the +first line of any button label. + +All following arguments are optional. If AS-LABEL is non-nil, +label is returned rather than the key derived from the label. +START-DELIM and END-DELIM are strings that override default +button delimiters. With POS-FLAG non-nil, returns list of +label-or-key, but-label-start-position, but-label-end-position. +Positions include delimiters. With TWO-LINES-FLAG non-nil, +constrains label search to two lines." + (ebut:label-p as-label (or start-delim ibut:label-start) + (or end-delim ibut:label-end) pos-flag two-lines-flag)) + +(defun ibut:label-regexp (lbl-key &optional no-delim) + "Unnormalizes ibutton LBL-KEY. Returns regular expr matching delimited button label. +Optional NO-DELIM leaves off delimiters and leading and trailing space." + (hbut:label-regexp lbl-key no-delim ibut:label-start ibut:label-end)) (defun ibut:label-set (label &optional start end) - "Sets current implicit button attributes from LABEL and START, END position. -Returns label. START and END are optional. When given, they specify the -region in the buffer to flash when this implicit button is activated or -queried for its attributes. If LABEL is a list, it is assumed to contain all -arguments." + "Sets current implicit button attributes from LABEL and optional START, END positions. +Returns label. When START and END are given, they specify the +region in the buffer to flash when this implicit button is +activated or queried for its attributes. If LABEL is a list, it +is assumed to contain all arguments." (cond ((stringp label) (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label)) (and start (hattr:set 'hbut:current 'lbl-start start)) @@ -1089,12 +1276,63 @@ arguments." (t (error "(ibut:label-set): Invalid label arg: `%s'" label))) label) +(defalias 'ibut:key-src 'hbut:key-src) +(defalias 'ibut:key-to-label 'hbut:key-to-label) +(defalias 'ibut:label-to-key 'hbut:label-to-key) +(defun ibut:next-occurrence (lbl-key &optional buffer) + "Moves point to next occurrence of a labeled implicit button with LBL-KEY in optional BUFFER. +BUFFER defaults to current buffer. It may be a buffer name. +Returns non-nil iff occurrence is found. + +Remember to use (goto-char (point-min)) before calling this in order to +move to the first occurrence of the button." + (if buffer + (if (not (or (bufferp buffer) + (and (stringp buffer) (get-buffer buffer)))) + (error "(ibut:next-occurrence): Invalid buffer arg: %s" buffer) + (switch-to-buffer buffer))) + (when (re-search-forward (ibut:label-regexp lbl-key) nil t) + (goto-char (+ (match-beginning 0) (length ibut:label-start))))) + +(defalias 'ibut:summarize 'hbut:report) + +(defun ibut:to (lbl-key) + "Find an implicit button in the current buffer with LBL-KEY (a label or lable key), leave point inside it or its label and return the button symbol for it, else nil." + ;; Handle a label given rather than a label key + (if (string-match-p "\\s-" lbl-key) + (setq lbl-key (ibut:label-to-key lbl-key))) + (let ((regexp (hbut:label-regexp lbl-key t)) + pos + found + reverse) + (save-excursion + (forward-line 0) + ;; re-search forward + (while (and (not found) (re-search-forward regexp nil t)) + (setq pos (goto-char (match-beginning 0)) + found (equal (ibut:at-p t) lbl-key))) + ;; re-search backward + (while (and (not found) (re-search-backward regexp nil t)) + (setq pos (goto-char (match-beginning 0)) + found (equal (ibut:at-p t) lbl-key)))) + (when found + (goto-char pos) + (ibut:at-p)))) + +;;; ------------------------------------------------------------------------ +(defconst ibut:label-start "<[" + "String matching the start of a Hyperbole implicit button label.") +(defconst ibut:label-end "]>" + "String matching the end of a Hyperbole implicit button label.") +(defvar ibut:label-separator "\\s-*[-:=]*\\s-+" + "Regular expression that separates an implicit button label from its implicit button text.") + ;;; ======================================================================== ;;; ibtype class - Implicit button types ;;; ======================================================================== -(defalias 'defib 'ibtype:create) -(put 'ibtype:create 'lisp-indent-function 'defun) +(defalias 'defib 'ibtype:create) +(put 'ibtype:create 'lisp-indent-function 'defun) (defmacro ibtype:create (type params doc at-p &optional to-p style) "Creates Hyperbole implicit button TYPE (unquoted sym) with PARAMS, described by DOC. PARAMS are presently ignored. diff --git a/hib-kbd.el b/hib-kbd.el index 339930a..8888668 100644 --- a/hib-kbd.el +++ b/hib-kbd.el @@ -65,12 +65,13 @@ Any key sequence must be a string of one of the following: ;; these are special quote marks, not the ;; standard ASCII characters. (hbut:label-p t "‘" "’" t))) + ;; This excludes delimiters (key-sequence (car seq-and-pos)) (start (cadr seq-and-pos)) binding) ;; Match only when start delimiter is preceded by whitespace or ;; is the 1st buffer character, so do not match to things like ${variable}. - (when (= (char-syntax (or (char-before start) ?\t)) ?\ ) + (when (memq (char-before start) '(nil ?\ ?\t ?\n ?\j ?\f)) (when (and (stringp key-sequence) (not (eq key-sequence ""))) (setq key-sequence (kbd-key:normalize key-sequence) @@ -171,17 +172,7 @@ With optional prefix arg FULL, displays full documentation for command." (string-to-number (substring norm-key-seq (match-beginning 2) (match-end 2))) norm-key-seq (substring norm-key-seq (match-end 0)))) - (let (arg-val) - (while (string-match "\\`C-u" norm-key-seq) - (if (or (not (listp arg)) - (not (integerp (setq arg-val (car arg))))) - (setq arg '(1) - arg-val 1)) - (setq arg-val (* arg-val 4) - arg (cons arg-val nil) - norm-key-seq (substring norm-key-seq (match-end 0))))) - (if arg (setq norm-key-seq (concat (format "\025%s" arg) norm-key-seq))) - ;; + ;; Quote Control and Meta key names (setq norm-key-seq (hypb:replace-match-string "C-\\(.\\)" norm-key-seq @@ -208,7 +199,7 @@ With optional prefix arg FULL, displays full documentation for command." (and (stringp key-sequence) (string-match kbd-key:extended-command-prefix key-sequence))) (defun kbd-key:hyperbole-hycontrol-key-p (key-sequence) - "Returns t if normalized KEY-SEQUENCE is given when in a HyControl mode, else nil. + "Returns t if normalized, non-nil KEY-SEQUENCE is given when in a HyControl mode, else nil. Allows for multiple key sequences strung together." (and key-sequence (featurep 'hycontrol) diff --git a/hibtypes.el b/hibtypes.el index 8aaae63..dd09470 100644 --- a/hibtypes.el +++ b/hibtypes.el @@ -64,7 +64,7 @@ (run-hooks 'hibtypes-begin-load-hook) ;;; ======================================================================== -;;; Follows Org mode links by invoking a web browser. +;;; Follows Org mode links and radio targets and cycles Org heading views ;;; ======================================================================== (require 'hsys-org) @@ -184,10 +184,9 @@ display options." ;;; ======================================================================== (defconst hibtypes-path-line-and-col-regexp - (if hyperb:microsoft-os-p - ;; Allow for 'c:' single letter drive prefixes on MSWindows - "\\([^ \t\n\r:][^ \t\n\r]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?" - "\\([^ \t\n\r:]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?")) + ;; Allow for 'c:' single letter drive prefixes on MSWindows and + ;; Elisp vars with colons in them. + "\\([^ \t\n\r\f:][^\t\n\r\f:]+\\(:[^0-9\t\n\r\f]*\\)*\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?$") (defib pathname-line-and-column () "Makes a valid pathname:line-num[:column-num] pattern display the path at line-num and optional column-num. @@ -200,10 +199,10 @@ See `hpath:find' function documentation for special file display options." (let ((path-line-and-col (hpath:delimited-possible-path))) (if (and (stringp path-line-and-col) (string-match hibtypes-path-line-and-col-regexp path-line-and-col)) - (let ((file (expand-file-name (match-string-no-properties 1 path-line-and-col))) - (line-num (string-to-number (match-string-no-properties 2 path-line-and-col))) - (col-num (if (match-end 3) (string-to-number (match-string-no-properties - 4 path-line-and-col))))) + (let ((file (save-match-data (expand-file-name (hpath:substitute-value (match-string-no-properties 1 path-line-and-col))))) + (line-num (string-to-number (match-string-no-properties 3 path-line-and-col))) + (col-num (if (match-end 4) (string-to-number (match-string-no-properties + 5 path-line-and-col))))) (when (save-match-data (setq file (hpath:is-p file))) (ibut:label-set file (match-beginning 1) (match-end 1)) (if col-num @@ -628,11 +627,112 @@ Requires the Emacs builtin Tramp library for ftp file retrievals." (require 'klink) ;;; ======================================================================== -;;; Jumps to source line associated with grep or compilation error messages. -;;; Also supports ripgrep (rg command). +;;; Links to Hyperbole button types +;;; ======================================================================== + + +(defconst elink:start "<elink:" + "String matching the start of a link to a Hyperbole explicit button.") +(defconst elink:end ">" + "String matching the end of a link to a Hyperbole explicit button.") + +(defib link-to-ebut () + "At point, activates a link to an explicit button. +The explicit button's action is executed in the context of the current buffer. + +Recognizes the format '<elink:' <button label> '>', e.g. <elink: project-list>." + (let* ((label-key-start-end (hbut:label-p nil elink:start elink:end t t)) + (lbl-key (nth 0 label-key-start-end)) + (start-pos (nth 1 label-key-start-end)) + (end-pos (nth 2 label-key-start-end))) + (when lbl-key + (ibut:label-set (ebut:key-to-label lbl-key) start-pos end-pos) + (hact 'link-to-ebut lbl-key)))) + +(defconst glink:start "<glink:" + "String matching the start of a link to a Hyperbole global button.") +(defconst glink:end ">" + "String matching the end of a link to a Hyperbole global button.") + +(defib link-to-gbut () + "At point, activates a link to a global button. +The global button's action is executed in the context of the current buffer. + +Recognizes the format '<glink:' <button label> '>', e.g. <glink: open todos>." + (let* ((label-key-start-end (hbut:label-p nil glink:start glink:end t t)) + (lbl-key (nth 0 label-key-start-end)) + (start-pos (nth 1 label-key-start-end)) + (end-pos (nth 2 label-key-start-end))) + (when lbl-key + (ibut:label-set (ebut:key-to-label lbl-key) start-pos end-pos) + (hact 'link-to-gbut lbl-key)))) + +(defconst ilink:start "<ilink:" + "String matching the start of a link to a Hyperbole implicit button.") +(defconst ilink:end ">" + "String matching the end of a link to a Hyperbole implicit button.") + +(defib link-to-ibut () + "At point, activates a link to an implicit button. +The implicit button's action is executed in the context of the current buffer. + +Recognizes the format '<ilink:' <button label> '>', e.g. <ilink: my sequence of keys>." + (let* ((label-key-start-end (ibut:label-p nil ilink:start ilink:end t t)) + (lbl-key (nth 0 label-key-start-end)) + (start-pos (nth 1 label-key-start-end)) + (end-pos (nth 2 label-key-start-end))) + (when lbl-key + (ibut:label-set (ibut:key-to-label lbl-key) start-pos end-pos) + (hact 'link-to-ibut lbl-key)))) + +;;; ======================================================================== +;;; Jumps to source line associated with ipython, ripgreb, grep or ;;; With credit to Michael Lipp and Mike Williams for the idea. ;;; ======================================================================== +(defib ipython-stack-frame () + "Jumps to line associated with an ipython stack frame line numbered msg. +ipython outputs each pathname once followed by all matching lines in that pathname. +Messages are recognized in any buffer (other than a helm completion +buffer)." + ;; Locate and parse ipython stack trace messages found in any buffer other than a + ;; helm completion buffer. + ;; + ;; Sample ipython stack trace command output: + ;; + ;; ~/Dropbox/py/inview/inview_pr.py in ap(name_filter, value_filter, print_func) + ;; 1389 apc(name_filter, value_filter, print_func, defined_only=True) + ;; 1390 print('\n**** Modules/Packages ****') + ;; -> 1391 apm(name_filter, value_filter, print_func, defined_only=True) + ;; 1392 + ;; 1393 def apa(name_filter=None, value_filter=None, print_func=pd1, defined_only=False): + (unless (eq major-mode 'helm-major-mode) + (save-excursion + (beginning-of-line) + (let ((line-num-regexp "\\( *\\|-+> \\)?\\([1-9][0-9]*\\) ") + line-num + file) + (when (looking-at line-num-regexp) + ;; ipython stack trace matches and context lines (-A<num> option) + (setq line-num (match-string-no-properties 2) + file nil) + (while (and (= (forward-line -1) 0) + (looking-at line-num-regexp))) + (unless (or (looking-at line-num-regexp) + (not (re-search-forward " in " nil (point-at-eol))) + (and (setq file (buffer-substring-no-properties (point-at-bol) (match-beginning 0))) + (string-empty-p (string-trim file)))) + (let* ((but-label (concat file ":" line-num)) + (source-loc (if (file-name-absolute-p file) + nil + (hbut:key-src t)))) + (if (stringp source-loc) + (setq file (expand-file-name file (file-name-directory source-loc)))) + (when (file-readable-p file) + (setq line-num (string-to-number line-num)) + (ibut:label-set but-label) + (hact 'link-to-file-line file line-num))))))))) + (defib ripgrep-msg () "Jumps to line associated with a ripgrep (rg) line numbered msg. Ripgrep outputs each pathname once followed by all matching lines in that pathname. @@ -688,7 +788,7 @@ in grep and shell buffers." (beginning-of-line) (if (or ;; Grep matches, UNIX C compiler and Introl 68HC11 C compiler errors - (looking-at "\\([^ \t\n\r:]+\\): ?\\([1-9][0-9]*\\)[ :]") + (looking-at "\\([^ \t\n\r:]+\\)[:\^@] ?\\([1-9][0-9]*\\)[ :]") ;; HP C compiler errors (looking-at "[a-zA-Z0-9]+: \"\\([^\t\n\r\",]+\\)\", line \\([0-9]+\\):") ;; BSO/Tasking 68HC08 C compiler errors @@ -733,13 +833,13 @@ This works with JavaScript and Python tracebacks, gdb, dbx, and xdb. Such lines (save-excursion (beginning-of-line) (cond - ;; Python pdb or traceback - ((looking-at ".+ File \"\\([^\"\n\r]+\\)\", line \\([0-9]+\\)") - (let* ((file (match-string-no-properties 1)) - (line-num (match-string-no-properties 2)) + ;; Python pdb or traceback, pytype error + ((looking-at "\\(^\\|.+ \\)File \"\\([^\"\n\r]+\\)\", line \\([0-9]+\\)") + (let* ((file (match-string-no-properties 2)) + (line-num (match-string-no-properties 3)) (but-label (concat file ":" line-num))) (setq line-num (string-to-number line-num)) - (ibut:label-set but-label (match-beginning 1) (match-end 1)) + (ibut:label-set but-label (match-beginning 2) (match-end 2)) (hact 'link-to-file-line file line-num))) ;; JavaScript traceback @@ -1010,8 +1110,11 @@ Activates only if point is within the first line of the Info-node name." (hbut:label-p t "``" "''" t t) ;; Regular open and close quotes (hbut:label-p t "`" "'" t t))) - (node-ref (hpath:is-p (car node-ref-and-pos) nil t))) - (and node-ref (string-match "\\`([^\):]+)" node-ref) + (ref (car node-ref-and-pos)) + (node-ref (and (stringp ref) + (string-match "\\`([^\):]+)" ref) + (hpath:is-p (car node-ref-and-pos) nil t)))) + (and node-ref (ibut:label-set node-ref-and-pos) (hact 'link-to-Info-node node-ref)))) diff --git a/hpath.el b/hpath.el index 51e1d14..00bd297 100644 --- a/hpath.el +++ b/hpath.el @@ -502,7 +502,7 @@ use with string-match.") (defconst hpath:markup-link-anchor-regexp (concat "\\`\\(#?[^#]+\\)\\(#\\)\\([^\]\[#^{}<>\"`'\\\n\t\f\r]*\\)") - "Regexp that matches an markup filename followed by a hash (#) and an optional in-file anchor name.") + "Regexp that matches a markup filename followed by a hash (#) and an optional in-file anchor name.") (defconst hpath:outline-section-pattern "^\*+[ \t]+%s\\([ \t[:punct:]]*\\)$" "Regexp matching an Emacs outline section header and containing a %s for replacement of a specific section name.") @@ -518,6 +518,9 @@ These are used to indicate how to display or execute the pathname. "\\`/[^/:]+:\\|\\`ftp[:.]\\|\\`www\\.\\|\\`https?:" "Regexp matching remote pathnames and urls which invoke remote file handlers.") +(defconst hpath:texinfo-section-pattern "^@node+[ \t]+%s[ \t]*\\(,\\|$\\)" + "Regexp matching a Texinfo section header and containing a %s for replacement of a specific section name.") + ;;; ************************************************************************ ;;; Public functions ;;; ************************************************************************ @@ -799,7 +802,8 @@ Returns non-nil iff file is displayed within a buffer (not with an external program)." (interactive "FFind file: ") (let ((case-fold-search t) - modifier loc dir anchor hash path) + (default-directory default-directory) + modifier loc anchor hash path) (if (string-match hpath:prefix-regexp filename) (setq modifier (aref filename 0) filename (substring filename (match-end 0)))) @@ -810,19 +814,17 @@ program)." (substring filename 0 (match-end 1))) filename)) loc (hattr:get 'hbut:current 'loc) - dir (file-name-directory - ;; Loc may be a buffer without a file - (if (stringp loc) loc default-directory)) - filename (hpath:absolute-to path dir)) + default-directory (file-name-directory + ;; Loc may be a buffer without a file + (if (stringp loc) loc default-directory)) + filename (hpath:absolute-to path default-directory)) (let ((remote-filename (hpath:remote-p path))) (or modifier remote-filename - (file-exists-p path) - (error "(hpath:find): \"%s\" does not exist" - (file-relative-name filename))) + (file-exists-p filename) + (error "(hpath:find): \"%s\" does not exist" filename)) (or modifier remote-filename - (file-readable-p path) - (error "(hpath:find): \"%s\" is not readable" - (file-relative-name filename))) + (file-readable-p filename) + (error "(hpath:find): \"%s\" is not readable" filename)) ;; If filename is a remote file (not a directory, we have to copy it to ;; a temporary local file and then display that. (when (and remote-filename (not (file-directory-p remote-filename))) @@ -894,9 +896,11 @@ program)." (anchor-name (subst-char-in-string ?- ?\ anchor))) (goto-char (point-min)) (if (re-search-forward (format - (if (string-match hpath:markdown-suffix-regexp buffer-file-name) - hpath:markdown-section-pattern - hpath:outline-section-pattern) + (cond ((string-match hpath:markdown-suffix-regexp buffer-file-name) + hpath:markdown-section-pattern) + ((eq major-mode 'texinfo-mode) + hpath:texinfo-section-pattern) + (t hpath:outline-section-pattern)) (regexp-quote anchor-name)) nil t) (progn (forward-line 0) (recenter 0)) @@ -1042,7 +1046,7 @@ nonexistent local paths are allowed." (not (string-match "[\t\n\r\"`'|{}\\]" path)) (or (not (hpath:www-p path)) (string-match "\\`ftp[:.]" path)) - (let ((remote-path (string-match "@.+:\\|^/.+:\\|..+:/" path))) + (let ((remote-path (string-match "\\(@.+:\\|^/.+:\\|..+:/\\).*[^:0-9/]" path))) (if (cond (remote-path (cond ((eq type 'file) (not (string-equal "/" (substring path -1)))) @@ -1510,15 +1514,15 @@ from path or t." Return nil if FILENAME is a directory name or an image file that emacs can display. See also documentation for the function (hpath:get-external-display-alist) and the variable `hpath:internal-display-alist'." - (cond ((let ((case-fold-search t)) - (hpath:match filename (hpath:get-external-display-alist)))) + (cond ((and (fboundp 'image-mode) + (string-match hpath:native-image-suffixes filename)) + nil) ((let ((case-fold-search nil)) (hpath:match filename hpath:internal-display-alist))) + ((let ((case-fold-search t)) + (hpath:match filename (hpath:get-external-display-alist)))) ((and (stringp filename) (file-directory-p filename)) nil) - ((and (fboundp 'image-mode) - (string-match hpath:native-image-suffixes filename)) - nil) ;; 01/21/2019 - RSW commented this next line out since it can ;; trigger external viewers on many file types that Emacs ;; displays natively. diff --git a/hsys-org.el b/hsys-org.el index 59a1eb1..2e9c117 100644 --- a/hsys-org.el +++ b/hsys-org.el @@ -29,6 +29,16 @@ (require 'hbut) (require 'org) +(defvar hsys-org-mode-function #'hsys-org-mode-p + "*Boolean function of no arguments that determines whether hsys-org actions are triggered or not.") + +(defun hsys-org-mode-p () + "Returns non-nil if an Org-related major or minor mode is active in the current buffer." + (or (derived-mode-p 'org-mode) + (and (boundp 'outshine-mode) outshine-mode) + (and (boundp 'poporg-mode) poporg-mode))) + + (defun hsys-org-cycle () "Calls org-cycle and forces it to be set as this-command to cycle through all states." (setq last-command 'org-cycle @@ -47,12 +57,22 @@ (defib org-mode () "Follows any Org mode link at point or cycles through views of the outline subtree at point." - (when (derived-mode-p 'org-mode) - (cond ((org-link-at-p) - (hact 'org-link nil)) - ((org-at-heading-p) - (hact 'hsys-org-cycle)) - (t (hact 'org-meta-return))))) + (when (funcall hsys-org-mode-function) + (let (start-end) + (cond ((setq start-end (org-internal-link-target-at-p)) + (org-set-ibut-label start-end) + (hact 'org-internal-link-target)) + ((org-radio-target-def-at-p) + (hact 'org-radio-target)) + ((setq start-end (org-link-at-p)) + (org-set-ibut-label start-end) + (hact 'org-link)) + ((org-at-heading-p) + (hact 'hsys-org-cycle)) + ((org-at-block-start-p) + (org-ctrl-c-ctrl-c)) + (t + (hact 'org-meta-return)))))) (defun org-mode:help (&optional _but) "If on an Org mode heading, cycles through views of the whole buffer outline. @@ -65,22 +85,187 @@ If on an Org mode link, displays standard Hyperbole help." (hact 'hsys-org-global-cycle) t)))) -(defact org-link (link) - "Follows an Org mode LINK. If LINK is nil, follows the link at point." +(defact org-link (&optional link) + "Follows an optional Org mode LINK to its target. +If LINK is nil, follows any link at point. Otherwise, triggers an error." (if (stringp link) (org-open-link-from-string link) ;; autoloaded - (org-open-at-point-global))) ;; autoloaded + (org-open-at-point))) ;; autoloaded + +(defact org-internal-link-target (&optional link-target) + "Follows an optional Org mode LINK-TARGET back to its link definition. +If LINK-TARGET is nil, follows any link target at point. Otherwise, triggers an error." + (let (start-end) + (cond ((stringp link-target) + (setq start-end t) + (org-search-internal-link-p link-target)) + ((null link-target) + (when (setq start-end (org-internal-link-target-at-p)) + (org-search-internal-link-p (buffer-substring-no-properties + (car start-end) (cdr start-end)))))) + (unless start-end + (error "(org-internal-link-target): Point must be on a link target (not the link itself)")))) + + +(defact org-radio-target (&optional target) + "Jumps to the next occurrence of an optional Org mode radio TARGET link. +If TARGET is nil and point is on a radio target definition or link, it +uses that one. Otherwise, triggers an error." + (let (start-end) + (cond ((stringp target) + (setq start-end t) + (org-to-next-radio-target-link target)) + ((null target) + (when (setq start-end (org-radio-target-at-p)) + (org-to-next-radio-target-link (buffer-substring-no-properties + (car start-end) (cdr start-end)))))) + (unless start-end + (error "(org-radio-target): Point must be on a radio target definition or link")))) ;;; ************************************************************************ ;;; Public functions ;;; ************************************************************************ -;; Assumes caller has already checked that the current buffer is in org-mode. +(defun org-region-with-text-property-value (pos property) + "Returns (start . end) buffer positions of the region around POS that shares its non-nil text PROPERTY value, else nil." + (if (null pos) (setq pos (point))) + (let ((property-value (get-text-property pos property)) + (start-point pos)) + (when property-value + ;; Can't use previous-single-property-change here because it + ;; ignores characters that lack the property, i.e. have nil values. + (if (bobp) + (setq start-point (point-min)) + (while (equal (get-text-property (1- start-point) property) property-value) + (setq start-point (1- start-point)))) + (cons start-point (next-single-property-change start-point property))))) + +(defun org-at-block-start-p () + "Returns non-nil if point is on the first line of an Org block definition, else nil." + (save-excursion + (forward-line 0) + (or (looking-at org-block-regexp) + (looking-at org-dblock-start-re)))) + (defun org-link-at-p () - "Returns non-nil iff point is on an Org mode link." + "Returns non-nil iff point is on an Org mode link. +Assumes caller has already checked that the current buffer is in org-mode." + (or (org-in-regexp org-any-link-re) + (org-face-at-p 'org-link))) + +;; Assumes caller has already checked that the current buffer is in org-mode. +(defun org-target-at-p () + "Returns non-nil iff point is on an Org mode radio target (definition) or link target (referent). +Assumes caller has already checked that the current buffer is in org-mode." + (org-face-at-p 'org-target)) + +(defun org-radio-target-link-at-p () + "Returns (target-start . target-end) positions iff point is on an Org mode radio target link (referent), else nil." + (and (get-text-property (point) 'org-linked-text) + (org-link-at-p) + (org-region-with-text-property-value (point) 'org-linked-text))) + +(defun org-radio-target-def-at-p () + "Returns (target-start . target-end) positions iff point is on an Org mode radio target (definition), including any delimiter characters, else nil." + (when (org-target-at-p) + (save-excursion + (if (not (looking-at "<<<")) + (goto-char (or (previous-single-property-change (point) 'face) (point-min)))) + (if (looking-at "<<<") + (goto-char (match-end 0))) + (and (get-text-property (point) 'org-linked-text) + (org-region-with-text-property-value (point) 'face))))) + +(defun org-radio-target-at-p () + "Returns (target-start . target-end) positions iff point is on an Org mode <<<radio target definition>>> or radio target link (referent), including any delimiter characters, else nil." + (or (org-radio-target-def-at-p) + (org-radio-target-link-at-p))) + +(defun org-internal-link-target-at-p () + "Returns (target-start . target-end) positions iff point is on an Org mode <<link target>>, including any delimiter characters, else nil." + (when (org-target-at-p) + (save-excursion + (if (not (looking-at "<<")) + (goto-char (or (previous-single-property-change (point) 'face) (point-min)))) + (if (looking-at "<<<?") + (goto-char (match-end 0))) + (and (not (get-text-property (point) 'org-linked-text)) + (org-region-with-text-property-value (point) 'face))))) + +(defun org-face-at-p (org-face-type) + "Returns `org-face-type` iff point is on a character with face `org-face-type', a symbol, else nil." (let ((face-prop (get-text-property (point) 'face))) - (or (eq face-prop 'org-link) - (and (listp face-prop) (memq 'org-link face-prop))))) + (when (or (eq face-prop org-face-type) + (and (listp face-prop) (memq org-face-type face-prop))) + org-face-type))) + +(defun org-search-internal-link-p (target) + "Searches from buffer start for an Org internal link definition matching TARGET. +White spaces are insignificant. Returns t if a link is found, else nil." + (if (string-match "<<.+>>" target) + (setq target (substring target 2 -2))) + (let ((re (format "%s" + (mapconcat #'regexp-quote + (split-string target) + "[ \t]+\\(?:\n[ \t]*\\)?"))) + (origin (point))) + (goto-char (point-min)) + (catch :link-match + (while (re-search-forward re nil t) + (backward-char) + (let ((object (org-element-context))) + (when (eq (org-element-type object) 'link) + (org-show-context 'link-search) + (throw :link-match t)))) + (goto-char origin) + nil))) + +(defun org-search-radio-target-link-p (target) + "Searches from point for a radio target link matching TARGET. +White spaces are insignificant. Returns t if a target link is found, else nil." + (if (string-match "<<<.+>>>" target) + (setq target (substring target 3 -3))) + (let ((re (format "%s" + (mapconcat #'regexp-quote + (split-string target) + "[ \t]+\\(?:\n[ \t]*\\)?"))) + (origin (point))) + (catch :radio-match + (while (re-search-forward re nil t) + (backward-char) + (let ((object (org-element-context))) + (when (eq (org-element-type object) 'link) + (org-show-context 'link-search) + (throw :radio-match t)))) + (goto-char origin) + nil))) + +(defun org-set-ibut-label (start-end) + "Record the label and START-END positions of any implicit button at point." + (when (consp start-end) + (ibut:label-set (ibut:key-to-label + (ibut:label-to-key + (buffer-substring-no-properties (car start-end) (cdr start-end)))) + (car start-end) (cdr start-end)))) + + +(defun org-to-next-radio-target-link (target) + "Moves to the start of the next radio TARGET link if found. TARGET must be a string." + (if (string-match "<<<.+>>>" target) + (setq target (substring target 3 -3))) + (let ((opoint (point)) + (start-end (org-radio-target-at-p)) + found) + (if start-end + ;; Move past any current target link + (goto-char (cdr start-end))) + (while (and (org-search-radio-target-link-p target) + (setq found t) + (not (org-radio-target-link-at-p)))) + (when found + (if (org-radio-target-link-at-p) + (goto-char (or (previous-single-property-change (point) 'face) (point-min))) + (goto-char opoint))))) ;;; ************************************************************************ ;;; Private functions diff --git a/htz.el b/htz.el index 3341d6b..6ff6713 100644 --- a/htz.el +++ b/htz.el @@ -61,8 +61,8 @@ Optional 2nd argument TIMEZONE specifies a timezone to be represented in." (defun htz:date-parse (date &optional parsed-current-date) "Parse DATE string and return a vector [year month day time timezone]. -19 is prepended to year if necessary. Timezone in DATE is optional, it -defaults to the value of `htz:local'. +If a two-digit year, the first two digits of the current year are prepended. +Timezone in DATE is optional, it defaults to the value of `htz:local'. Recognizes the following styles: (1) \"(1 30 1999)\" or \"(1 30 1999)\" `calendar-julian-date' requires `parsed-current-date' arg @@ -73,11 +73,8 @@ Recognizes the following styles: (6) \"Mar 29 14:00\" `ls -l date' requires `parsed-current-date' arg (7) \"Mar 7 1994\" `ls -l date' requires `parsed-current-date' arg" (let ((date (or date "")) - (year nil) - (month nil) - (day nil) - (time nil) - (zone nil)) ; This may be nil. + year month day time + zone) ; This may be nil. (if (listp date) (setq month (nth 0 date) day (nth 1 date) @@ -87,31 +84,34 @@ Recognizes the following styles: ;; Style (1) (setq year 3 month 1 day 2 time nil zone nil)) ((string-match - "\\([0-9][0-9][0-9][0-9]\\)\\([0-1][0-9]\\)\\([0-3][0-9]\\):?\\([0-2][0-9]:[0-5][0-9:]+\\)[ ]*\\'" date) - ;; Style (4) + ;; Allow for 3 digits in hour to handle prior error in + ;; generating hours fixed on 2019-06-10; 3rd digit + ;; removed in htz:time-make-string and htz:time-parse. + "\\([0-9][0-9][0-9][0-9]\\)\\([0-1][0-9]\\)\\([0-3][0-9]\\):?\\([0-9][0-9][0-9]?:[0-5][0-9:]+\\)[ ]*\\'" date) + ;; Style (5) (setq year 1 month 2 day 3 time 4 zone nil)) ((string-match "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9]+:[0-9:]+\\)[ ]*\\'" date) - ;; Styles: (1) and (2) without timezone + ;; Styles: (2) and (3) without timezone (setq year 3 month 2 day 1 time 4 zone nil)) ((string-match "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9]+:[0-9:]+\\)[ ]*\\([-+a-zA-Z0-9]+\\)" date) - ;; Styles: (1) and (2) with timezone and buggy timezone + ;; Styles: (2) and (3) with timezone and buggy timezone (setq year 3 month 2 day 1 time 4 zone 5)) ((string-match - "\\([^ ,]+\\) +\\([0-9]+\\) \\([0-9]+:[0-9:]+\\) \\([0-9]+\\)" date) - ;; Styles: (3) without timezone - (setq year 4 month 1 day 2 time 3 zone nil)) + "\\([^ ,]+\\) +\\([0-9]+\\) \\([0-9]+:[0-9:]+\\(:[0-9]+\\)?\\) \\([0-9]+\\)" date) + ;; Styles: (4) without timezone + (setq year 5 month 1 day 2 time 3 zone nil)) ((string-match - "\\([^ ,]+\\) +\\([0-9]+\\) \\([0-9]+:[0-9:]+\\) \\([-+a-zA-Z0-9]+\\) \\([0-9]+\\)" date) - ;; Styles: (3) with timezone - (setq year 5 month 1 day 2 time 3 zone 4)) + "\\([^ ,]+\\) +\\([0-9]+\\) \\([0-9]+:[0-9:]+\\(:[0-9]+\\)?\\) \\([-+a-zA-Z0-9]+\\) \\([0-9]+\\)" date) + ;; Styles: (4) with timezone + (setq year 6 month 1 day 2 time 3 zone 5)) ((string-match "^\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9]+:[0-9:]+\\)$" date) - ;; Style: (5) + ;; Style: (6) (setq year nil month 1 day 2 time 3 zone nil)) ((string-match "^\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9][0-9][0-9][0-9]\\)$" date) - ;; Style: (6) + ;; Style: (7) (setq year 3 month 1 day 2 time nil zone nil)) (t (error "(htz:date-parse): Invalid date format: `%s'" date))) (if year @@ -249,7 +249,10 @@ See `htz:date-parse' for a list of acceptable date formats." ;; Return [hour minute second] (vector (if hour - (substring time (match-beginning hour) (match-end hour)) "0") + ;; Remove possible 3rd digit in hour to handle prior error in + ;; generating hours fixed on 2019-06-10; 3rd digit + ;; removed in htz:time-make-string and here. + (format "%02.2s" (substring time (match-beginning hour) (match-end hour))) "0") (if minute (substring time (match-beginning minute) (match-end minute)) "0") (if second @@ -322,7 +325,7 @@ Optional argument TIMEZONE specifies a time zone." ;; Partly copied from Calendar program by Edward M. Reingold. (defun htz:time-make-string (hour minute second) "Make time string from HOUR, MINUTE, and SECOND." - (format "%02d:%02d:%02d" hour minute second)) + (format "%02.2d:%02.2d:%02.2d" hour minute second)) (defun htz:zone-to-hour (timezone) "Translate TIMEZONE (in zone name or integer) to integer hour." diff --git a/hui-mouse.el b/hui-mouse.el index 0878500..d3396b2 100644 --- a/hui-mouse.el +++ b/hui-mouse.el @@ -243,9 +243,9 @@ Its default value is #'smart-scroll-down." ;; ;; Python files - ensure this comes before Imenu for more advanced ;; definition lookups - ((and (or (and (eq major-mode 'python-mode) buffer-file-name) + ((and (or (and (derived-mode-p 'python-mode) buffer-file-name) (let ((case-fold-search)) - (string-match "\\`\\(Pydoc:\\|\\*?Python\\)" (buffer-name)))) + (string-match "\\`\\([ *]?Pydoc[: ]\\|\\*?Python\\)" (buffer-name)))) (setq hkey-value (smart-python-at-tag-p))) . ((smart-python hkey-value) . (smart-python hkey-value 'next-tag))) ;; diff --git a/hui.el b/hui.el index f0d1d48..325f287 100644 --- a/hui.el +++ b/hui.el @@ -66,7 +66,7 @@ (message "{%s} now runs `%s'" new-key-text cmd)))) (defun hui:ebut-create (&optional start end) - "Creates an explicit but starting from label between optional START and END. + "Creates an explicit Hyperbole button starting from label between optional START and END. Indicates by delimiting and adding any necessary instance number of the button label." (interactive (list (and (marker-position (hypb:mark-marker t)) @@ -722,8 +722,8 @@ All args are optional, the current button and buffer file are the defaults." (defun hui:hbut-term-highlight (start end) "For terminals only: Emphasize a button spanning from START to END." - (save-restriction - (save-excursion + (save-excursion + (save-restriction (goto-char start) (narrow-to-region (point-min) start) (sit-for 0) @@ -737,8 +737,8 @@ All args are optional, the current button and buffer file are the defaults." (defun hui:hbut-term-unhighlight (start end) "For terminals only: Remove any emphasis from hyper-button at START to END." - (save-restriction - (save-excursion + (save-excursion + (save-restriction (goto-char start) (narrow-to-region (point-min) start) (sit-for 0) @@ -834,7 +834,7 @@ button's source file name when the button data is stored externally." (t but-buf)))) (defun hui:link-create (modify but-window lbl-key but-loc but-dir type-and-args) - "Creates or modifies a new Hyperbole link button. + "Creates or modifies a new Hyperbole explicit link button. If MODIFY is non-nil, modifies button at point in BUT-WINDOW, otherwise, prompts for button label and creates a button. LBL-KEY is internal form of button label. BUT-LOC is file or buffer @@ -862,7 +862,9 @@ possible types. Referent Context Possible Link Type Returned ---------------------------------------------------- +Global Button link-to-gbut Explicit Button link-to-ebut +Implicit Button link-to-ibut Info Index Item link-to-Info-index-item Info Node link-to-Info-node Mail Reader Message link-to-mail @@ -877,8 +879,12 @@ Buffer without File link-to-buffer-tmp" (let (val) (delq nil - (list (if (ebut:at-p) - (list 'link-to-ebut buffer-file-name (ebut:label-p))) + (list (cond ((eq (current-buffer) (get-file-buffer gbut:file)) + (list 'link-to-gbut buffer-file-name (hbut:label-p))) + ((ebut:at-p) + (list 'link-to-ebut buffer-file-name (ebut:label-p))) + ((setq val (ibut:at-p t)) + (list 'link-to-ibut buffer-file-name val))) (cond ((eq major-mode 'Info-mode) (if (and Info-current-node (member Info-current-node diff --git a/hypb.el b/hypb.el index f156592..f896305 100644 --- a/hypb.el +++ b/hypb.el @@ -220,7 +220,10 @@ Global keymap is used unless optional KEYMAP is given." (defun hypb:error (&rest args) "Signals an error typically to be caught by `hyperbole'." - (let ((msg (if (< (length args) 2) (car args) (apply 'format args)))) + (let ((msg (if (< (length args) 2) + (car args) + (apply 'format (cons (car args) + (mapcar #'hypb:format-quote (cdr args))))))) (put 'error 'error-message msg) (error msg))) @@ -233,14 +236,16 @@ FILE is temporarily read into a buffer to determine the major mode if necessary. (unless (or existing-flag (null buf)) (kill-buffer buf))))) -(defun hypb:format-quote (string) - "Replace all single % with %% in STRING so a call to `format' or `message' ignores them." - (if (stringp string) +(defun hypb:format-quote (arg) + "Replace all single % with %% in any string ARG so that a call to `format' or `message' ignores them. +Return either the modified string or the original ARG." + (if (stringp arg) (replace-regexp-in-string "@@@" "%%" (replace-regexp-in-string - "%" "%%" (replace-regexp-in-string "%%" "@@@" string nil t) + "%" "%%" (replace-regexp-in-string "%%" "@@@" arg nil t) nil t) - nil t))) + nil t) + arg)) (defun hypb:function-copy (func-symbol) "Copies FUNC-SYMBOL's body for overloading. Returns copy of body." diff --git a/hyperbole.el b/hyperbole.el index b8d2340..3a6cda2 100644 --- a/hyperbole.el +++ b/hyperbole.el @@ -300,7 +300,7 @@ With third argument NO-ADD non-nil, skip storage of prior KEY binding which prevents automatic removal of any local bindings to the same key." (or (global-key-binding key) (where-is-internal command) - (hkey-global-set-key key command))) + (hkey-global-set-key key command no-add))) (defun hkey-set-bindings (key-binding-list) "Set keys bound by Hyperbole to those in KEY-BINDING-LIST. diff --git a/hyrolo.el b/hyrolo.el index 741fdd8..b6058ff 100644 --- a/hyrolo.el +++ b/hyrolo.el @@ -183,10 +183,8 @@ entry which begins with the parent string." parent (substring name 0 end) name (substring name (min (1+ end) (length name)))) (if (re-search-forward - (concat "\\(" hyrolo-entry-regexp "\\)[ \t]*" - (regexp-quote parent)) nil t) - (setq level (buffer-substring-no-properties (match-beginning 1) - (match-end 1))) + (concat hyrolo-entry-regexp (regexp-quote parent)) nil t) + (setq level (match-string-no-properties hyrolo-entry-group-number)) (error "(hyrolo-add): `%s' category not found in \"%s\"." parent file))) (narrow-to-region (point) @@ -204,10 +202,10 @@ entry which begins with the parent string." ;; entry by moving to an entry with the same (or nearest) first character ;; to that of `name'. (if (and (= level-len 1) - (equal hyrolo-entry-regexp "^\\*+")) + (equal hyrolo-entry-regexp "^\\(\\*+\\)\\([ \t]+\\)")) (progn (goto-char (point-min)) - (if (re-search-forward (concat "^\\*[ \t]*" - (char-to-string first-char)) + (if (re-search-forward (concat hyrolo-entry-regexp + (regexp-quote (char-to-string first-char))) nil t) (goto-char (match-beginning 0)) (goto-char (point-max)) @@ -229,17 +227,12 @@ entry which begins with the parent string." (setq again nil))))) (goto-char (point-min))) - (while (and again - (re-search-forward - (concat "\\(" hyrolo-entry-regexp "\\)\\([ \t]*\\)") - nil 'end)) - (setq entry-level (buffer-substring-no-properties (match-beginning 1) - (match-end 1))) + (while (and again (re-search-forward hyrolo-entry-regexp nil 'end)) + (setq entry-level (match-string-no-properties hyrolo-entry-group-number)) (if (/= (length entry-level) level-len) (hyrolo-to-entry-end t entry-level) (setq entry (buffer-substring-no-properties (point) (+ (point) len)) - entry-spc (buffer-substring-no-properties (match-beginning 2) - (match-end 2))) + entry-spc (match-string-no-properties hyrolo-entry-trailing-space-group-number)) (cond ((string< entry name) (hyrolo-to-entry-end t entry-level)) ((string< name entry) @@ -528,7 +521,7 @@ Returns t if entry is killed, nil otherwise." (defun hyrolo-locate () "Interactively search for an entry beginning with a set of search characters." (interactive) - (hyrolo-isearch-for-regexp (concat hyrolo-entry-regexp "[ \t]*"))) + (hyrolo-isearch-for-regexp hyrolo-entry-regexp)) (defun hyrolo-mail-to () "Start composing mail addressed to the first e-mail address at or after point." @@ -1270,8 +1263,7 @@ Name is returned as `last, first-and-middle'." "\\([^\" \t()]+\\)[ \t]*[)\"]\\)?[ \t]*$") from) (setq name (hyrolo-format-name from 3 4)) - (or email (setq email (substring from (match-beginning 1) - (match-end 1))))) + (or email (setq email (match-string 1 from)))) ;; Match: <email>, name <email>, "name" <email> ((string-match (concat "^\\(\"?\\([^\"<>()\n]+\\)[ \t]+" @@ -1279,8 +1271,7 @@ Name is returned as `last, first-and-middle'." "<\\([^\"<>() \t\n\r\f]+\\)>[ \t]*$") from) (setq name (hyrolo-format-name from 2 3)) - (or email (setq email (substring from (match-beginning 4) - (match-end 4))))))) + (or email (setq email (match-string 4 from)))))) (if (or name email) (list name email)))) @@ -1295,8 +1286,7 @@ Name is returned as `last, first-and-middle'." (skip-chars-forward " \t") (if (or (looking-at "[^ \t\n\r]+ ?, ?[^ \t\n\r]+") (looking-at "\\( ?[^ \t\n\r]+\\)+")) - (buffer-substring-no-properties (match-beginning 0) - (match-end 0)))))))) + (match-string-no-properties 0))))))) (defun hyrolo-narrowed-p () (or (/= (point-min) 1) (/= (1+ (buffer-size)) (point-max)))) @@ -1387,11 +1377,8 @@ Returns point where matching entry begins or nil if not found." (while (and (not level) (search-forward parent nil t)) (save-excursion (beginning-of-line) - (if (looking-at - (concat "\\(" hyrolo-entry-regexp "\\)[ \t]*" - (regexp-quote parent))) - (setq level (buffer-substring-no-properties (match-beginning 1) - (match-end 1)))))) + (if (looking-at (concat hyrolo-entry-regexp (regexp-quote parent))) + (setq level (match-string-no-properties hyrolo-entry-group-number))))) level)) ((equal name real-name)) ;; Try next file. (t ;; Found parent but not child @@ -1409,9 +1396,7 @@ Returns point where matching entry begins or nil if not found." (beginning-of-line) (setq found (if (looking-at - (concat "\\(" hyrolo-entry-regexp - "\\)[ \t]*" - (regexp-quote name))) + (concat hyrolo-entry-regexp (regexp-quote name))) (point)))))))) (or found (hyrolo-kill-buffer))) ;; conditionally kill (widen) @@ -1462,10 +1447,18 @@ Calls the functions given by `hyrolo-mode-hook'. "Buffer used to display set of last matching rolo entries.") (define-obsolete-variable-alias 'rolo-display-buffer 'hyrolo-display-buffer "06.00") -(defvar hyrolo-entry-regexp "^\\*+" +(defvar hyrolo-entry-group-number 1 + "Group number within `hyrolo-entry-regexp' whose length represents the level of any entry matched.") + +(defvar hyrolo-entry-trailing-space-group-number 2 + "Group number within `hyrolo-entry-regexp; containing trailing space.") + +(defvar hyrolo-entry-regexp "^\\(\\*+\\)\\([ \t]+\\)" "Regular expression to match the beginning of a rolo entry. -This pattern must match the beginning of the line. Entries may be nested -through the use of increasingly longer beginning patterns.") +This pattern must match the beginning of the line. Use +`hyrolo-entry-group-number' to compute the entry's level in the +hierarchy. Use `hyrolo-entry-trailing-space-group-number' to capture +the whitespace following the entry hierarchy level.") (define-obsolete-variable-alias 'rolo-entry-regexp 'hyrolo-entry-regexp "06.00") (defconst hyrolo-hdr-format diff --git a/kotl/kfill.el b/kotl/kfill.el index d1be8ea..a3e0c28 100644 --- a/kotl/kfill.el +++ b/kotl/kfill.el @@ -18,12 +18,6 @@ ;;; Public variables ;;; ************************************************************************ -(defvar kfill:function-table - (if (boundp 'filladapt-function-table) - filladapt-function-table - (list (cons 'fill-paragraph (symbol-function 'fill-paragraph)))) - "Table containing the old function definitions that kfill overrides.") - (defvar kfill:prefix-table '( ;; Lists with hanging indents, e.g. @@ -106,44 +100,44 @@ number of lines that could not be moved, otherwise 0." ;; Need this or Emacs ignores fill-prefix when inside a ;; comment. (comment-multi-line t) + (fill-paragraph-handle-comment t) fill-prefix) (kfill:adapt nil) (do-auto-fill)) (do-auto-fill)))) -;;; Redefine this built-in function. - -(defun fill-paragraph (arg &optional skip-prefix-remove) - "Fill paragraph at or after point. Prefix ARG means justify as well." - (interactive "*P") - (if (not (eq major-mode 'kotl-mode)) - (kfill:funcall 'fill-paragraph arg) - ;; This may be called from `fill-region-as-paragraph' in "filladapt.el" - ;; which narrows the region to the current paragraph. A side-effect is - ;; that the cell identifier and indent information needed by this function - ;; when in kotl-mode is no longer visible. So we temporarily rewiden the - ;; buffer here. Don't rewiden past the paragraph of interest or any - ;; following blank line may be removed by the filling routines. - (save-restriction - (if (eq major-mode 'kotl-mode) - (narrow-to-region 1 (point-max))) - ;; Emacs expects a specific symbol here. - (if (and arg (not (symbolp arg))) (setq arg 'full)) - (or skip-prefix-remove (kfill:remove-paragraph-prefix)) - (catch 'done - (if (null fill-prefix) - (let ((paragraph-ignore-fill-prefix nil) - ;; Need this or Emacs ignores fill-prefix when - ;; inside a comment. - (comment-multi-line t) - (paragraph-start paragraph-start) - (paragraph-separate paragraph-separate) - fill-prefix) - (if (kfill:adapt t) - (throw 'done (kfill:funcall 'fill-paragraph arg))))) - ;; Kfill:adapt failed or fill-prefix is set, so do a basic - ;; paragraph fill as adapted from par-align.el. - (kfill:fallback-fill-paragraph arg skip-prefix-remove))))) +(defun kfill:fill-paragraph (&optional arg skip-prefix-remove) + "Fill paragraph at or after point when in kotl-mode. Prefix ARG means justify as well." + (interactive (progn + (barf-if-buffer-read-only) + (list (if current-prefix-arg 'full) nil))) + ;; This may be called from `fill-region-as-paragraph' in "filladapt.el" + ;; which narrows the region to the current paragraph. A side-effect is + ;; that the cell identifier and indent information needed by this function + ;; when in kotl-mode is no longer visible. So we temporarily rewiden the + ;; buffer here. Don't rewiden past the paragraph of interest or any + ;; following blank line may be removed by the filling routines. + (save-restriction + (if (eq major-mode 'kotl-mode) + (narrow-to-region 1 (point-max))) + ;; Emacs expects a specific symbol here. + (if (and arg (not (symbolp arg))) (setq arg 'full)) + (or skip-prefix-remove (kfill:remove-paragraph-prefix)) + (catch 'done + (if (null fill-prefix) + (let ((paragraph-ignore-fill-prefix nil) + ;; Need this or Emacs ignores fill-prefix when + ;; inside a comment. + (comment-multi-line t) + (fill-paragraph-handle-comment t) + (paragraph-start paragraph-start) + (paragraph-separate paragraph-separate) + fill-prefix) + (if (kfill:adapt t) + (throw 'done (fill-paragraph arg))))) + ;; Kfill:adapt failed or fill-prefix is set, so do a basic + ;; paragraph fill as adapted from par-align.el. + (kfill:fallback-fill-paragraph arg skip-prefix-remove)))) ;;; ;;; Redefine this built-in function so that it sets `prior-fill-prefix' also. @@ -154,16 +148,17 @@ Also sets `prior-fill-prefix' to the previous value of `fill-prefix'. Filling removes any prior fill prefix, adjusts line lengths and then adds the fill prefix at the beginning of each line." (interactive) - (setq prior-fill-prefix fill-prefix - fill-prefix (if turn-off - nil - (buffer-substring - (save-excursion (beginning-of-line) (point)) - (point)))) - (if (equal prior-fill-prefix "") - (setq prior-fill-prefix nil)) - (if (equal fill-prefix "") - (setq fill-prefix nil)) + (setq prior-fill-prefix fill-prefix) + (let ((left-margin-pos (save-excursion (move-to-left-margin) (point)))) + (if (> (point) left-margin-pos) + (setq fill-prefix (if turn-off + nil + (buffer-substring left-margin-pos (point)))) + (setq fill-prefix nil))) + (when (equal prior-fill-prefix "") + (setq prior-fill-prefix nil)) + (when (equal fill-prefix "") + (setq fill-prefix nil)) (cond (fill-prefix (message "fill-prefix: \"%s\"; prior-fill-prefix: \"%s\"" fill-prefix (or prior-fill-prefix ""))) @@ -226,10 +221,6 @@ fill prefix at the beginning of each line." (funcall function justify-flag))) (fill-region-as-paragraph from (point) justify-flag))))) -(defun kfill:funcall (function &rest args) - "Call the original FUNCTION with rest of ARGS that kfill overloaded." - (apply (cdr (assq function kfill:function-table)) args)) - (defun kfill:hanging-list (paragraph) (let (prefix match beg end) (setq prefix (make-string (- (match-end 0) (match-beginning 0)) ?\ )) diff --git a/kotl/kotl-mode.el b/kotl/kotl-mode.el index 427d76d..eb14fed 100644 --- a/kotl/kotl-mode.el +++ b/kotl/kotl-mode.el @@ -79,6 +79,7 @@ It provides the following keys: ;; Some package such as filladapt has overwritten the primitives ;; defined in kfill.el, so reload it. (load "kfill")) + (setq fill-paragraph-function #'kfill:fill-paragraph) ;; Ensure that outline structure data is saved when save-buffer is called ;; from save-some-buffers, {C-x s}. (add-hook 'local-write-file-hooks #'kotl-mode:update-buffer) @@ -153,7 +154,7 @@ It provides the following keys: (kvspec:activate)))) ;; We have been converting a buffer from a foreign format to a koutline. ;; Now that it is converted, ensure that `kotl-previous-mode' is set to - ;; koutline now. + ;; koutline. (setq kotl-previous-mode 'kotl-mode) (run-hooks 'kotl-mode-hook) (add-hook 'change-major-mode-hook #'kotl-mode:show-all nil t)) @@ -672,15 +673,17 @@ too long." With arg N, insert N newlines." (interactive "*p") (let* ((bolp (and (kotl-mode:bolp) (not (kotl-mode:bocp)))) - (indent (kcell-view:indent))) + (indent (kcell-view:indent)) + (add-prefix (and (stringp fill-prefix) + (not (string-empty-p fill-prefix))))) (while (> arg 0) (save-excursion (insert ?\n) - (if (and (not bolp) fill-prefix) + (if (and (not bolp) add-prefix) (insert fill-prefix) (insert-char ?\ indent))) (setq arg (1- arg))) - (if (and bolp fill-prefix) + (if (and bolp add-prefix) (progn (delete-horizontal-space) (insert fill-prefix))))) @@ -2537,7 +2540,8 @@ With optional prefix ARG, toggle display of blank lines between cells." (kview:set-attr kview 'lines-to-show 0) (outline-flag-region (point-min) (point-max) nil) (if arg (kvspec:toggle-blank-lines)) - (kvspec:update t)))) + (if (called-interactively-p 'interactive) + (kvspec:update t))))) ;;;###autoload (defun kotl-mode:top-cells (&optional arg) diff --git a/kotl/kvspec.el b/kotl/kvspec.el index b68cb7c..9e0ee89 100644 --- a/kotl/kvspec.el +++ b/kotl/kvspec.el @@ -114,15 +114,14 @@ display all levels of cells." (kview:set-attr kview 'levels-to-show levels-to-keep)) (defun kvspec:show-lines-per-cell (num) - "Show NUM lines per cell." + "Show NUM lines per visible cell; 0 means show all lines in each visible cell." (if (or (not (integerp num)) (< num 0)) (error "(kvspec:show-lines-per-cell): Invalid lines per cell, `%d'" num)) (kview:set-attr kview 'lines-to-show num) - (if (not (zerop num)) - ;; Now show NUM lines in cells. - (kview:map-tree (lambda (kview) - (kcell-view:expand (point)) - (kvspec:show-lines-this-cell num)) kview t t))) + ;; Now show NUM lines in cells. + (kview:map-tree (lambda (kview) + (kcell-view:expand (point)) + (kvspec:show-lines-this-cell num)) kview t t)) (defun kvspec:toggle-blank-lines () "Toggle blank lines between cells on or off." @@ -224,32 +223,25 @@ view specs." ;; "l" means use value of kview:default-levels-to-show. ;; "l0" means show all levels. (let (levels) - (if (not (string-match "l\\([0-9]+\\)?" kvspec:current)) - ;; Don't change the view if no view spec is given but note that - ;; all levels should be shown in the future. - (kview:set-attr kview 'levels-to-show 0) - (if (match-beginning 1) - (setq levels (string-to-number (match-string 1 kvspec:current))) - (setq levels kview:default-levels-to-show)) - (kvspec:levels-to-show levels)))) + (if (and (string-match "l\\([0-9]+\\)?" kvspec:current) + (match-beginning 1)) + (setq levels (string-to-number (match-string 1 kvspec:current))) + (setq levels kview:default-levels-to-show)) + (kvspec:levels-to-show levels))) (defun kvspec:lines-to-show () "Show a set number of lines per cell according to `kvspec:current'." - ;; "c" means use value of kview:default-lines-to-show. + ;; "c" or no "c" means use value of kview:default-lines-to-show. ;; "c0" means show all lines. - (cond ((not (string-match "c\\([0-9]+\\)?" kvspec:current)) - ;; Don't change the view if no view spec is given but note that all - ;; lines should be shown in the future. - (kview:set-attr kview 'lines-to-show 0)) - ((match-beginning 1) - (kvspec:show-lines-per-cell - (string-to-number (match-string 1 kvspec:current)))) - (t (kvspec:show-lines-per-cell kview:default-lines-to-show)))) + (if (and (string-match "c\\([0-9]+\\)?" kvspec:current) + (match-beginning 1)) + (kvspec:show-lines-per-cell + (string-to-number (match-string 1 kvspec:current))) + (kvspec:show-lines-per-cell kview:default-lines-to-show))) (defun kvspec:numbering () "Set the type of numbering (label) display according to `kvspec:current'." - (if (not (string-match "n\\([.*~0-2]\\)?" kvspec:current)) - nil + (when (string-match "n\\([.*~0-2]\\)?" kvspec:current) ;; "n" means use value of kview:default-label-type. ;; "n0" means display idstamps. ;; "n1" means display alpha labels. @@ -259,22 +251,21 @@ view specs." ;; "n~" means no labels. (let (spec type) (if (match-beginning 1) - (setq spec (string-to-char - (substring kvspec:current - (match-beginning 1) (match-end 1))) + (setq spec (string-to-char (match-string 1 kvspec:current)) type (cdr (assq spec kvspec:label-type-alist))) (setq type kview:default-label-type)) (kview:set-label-type kview type)))) (defun kvspec:show-lines-this-cell (num) "Assume the current cell is fully expanded and collapse to show NUM lines within it. -If NUM is greater than the number of lines available, the cell remains fully expanded." +If NUM is less than 1 or greater than the number of lines available, the cell remains fully expanded." ;; Use free variable label-sep-len bound in kview:map-* for speed. - (let ((start (goto-char (kcell-view:start (point) label-sep-len))) - (end (kcell-view:end-contents))) - ;; Hide all but num lines of the cell. - (and (> num 0) (search-forward "\n" end t num) - (outline-flag-region (1- (point)) end t)))) + (unless (< num 1) + (let ((start (goto-char (kcell-view:start (point) label-sep-len))) + (end (kcell-view:end-contents))) + ;; Hide all but num lines of the cell. + (and (search-forward "\n" end t num) + (outline-flag-region (1- (point)) end t))))) (defun kvspec:update-modeline () "Setup or update display of the current kview spec in the modeline." diff --git a/man/hyperbole.texi b/man/hyperbole.texi index 4b3c352..f57abee 100644 --- a/man/hyperbole.texi +++ b/man/hyperbole.texi @@ -2679,7 +2679,9 @@ upon the referent context in which the Action Key is released. @example Referent Context Link Type ---------------------------------------------------- +Global Button link-to-gbut Explicit Button link-to-ebut +Implicit Button link-to-ibut Info Index Item link-to-Info-index-item Info Node link-to-Info-node Mail Reader Message link-to-mail @@ -6494,58 +6496,29 @@ be of interest to users. @cindex referent display @cindex link display @cindex display where +@cindex display outside Emacs @cindex where to display +@cindex image display +@cindex internal display +@cindex external display Hyperbole lets you control where link referents are displayed and even what Emacs function or external program is used to display them. -There are three categories of referents, each with its own display -setting: +There are four categories of referents, each with its own display +setting, listed in decreasing order of priority. + @example Referent Category Variable Setting ======================================================================== -Internal Standard Display hpath:display-where +Internal Image Display hpath:native-image-suffixes Internal Custom Display hpath:internal-display-alist External Display hpath:external-display-alist +Internal Standard Display hpath:display-where @end example -@cindex menu, Cust/Referents -@kindex C-h h c r -Regular file links are displayed in an Emacs window specified by the -@code{hpath:display-where} setting which may be changed with the Cust/Referents -@bkbd{C-h h c r} menu. - @noindent -Available options are: - -@table @emph -@item @bullet{} Any-Frame -Display in the selected window of another existing frame -@item @bullet{} Current-Win -Display in the selected (current) window -@item @bullet{} Diff-Frame-One-Win -Display in the selected window of another existing frame, deleting its other windows -@item @bullet{} New-Frame -Display in a new single window frame -@item @bullet{} Other-Win -Display in another, possibly new window of the selected frame (this is -the default) -@item @bullet{} Single-Win -Display in a window of the selected frame and delete its other windows -@end table - -@page -@noindent -Alternatively, you can use the Hyperbole menubar menu as shown here: - -@float Image,image:Menu-Display-Referents -@caption{Display Referents Menu} -@image{im/menu-display-referents,6in,,Display Referents Menu} -@end float -@sp 1 - -@noindent -Continue reading the next sections for information on custom Internal -and External Viewers for link referencts. +Continue reading the next sections for information on how referents +are displayed internally and externally. @node Internal Viewers, External Viewers, Referent Display, Customization @subsection Internal Viewers @@ -6554,6 +6527,13 @@ and External Viewers for link referencts. @cindex display function @cindex internal viewer @cindex link, display function + +@cindex internal image display +@vindex hpath:native-image-suffixes +@cindex internal custom display +@vindex hpath:internal-display-alist +@cindex internal standard display +@vindex hpath:display-where When given a file name, Hyperbole will by default display the file for editing within an Emacs buffer. The @code{hpath:internal-display-alist} variable can be used to specify file name patterns, such as matching @@ -6579,6 +6559,42 @@ Files with an @file{.rdb} suffix are displayed as relational databases using the available with InfoDock. @end table +@cindex menu, Cust/Referents +@kindex C-h h c r +Links to standard files, those which don't match any special referent +category, are displayed in an Emacs window specified by the +@code{hpath:display-where} setting. It may be changed with the Cust/Referents +@bkbd{C-h h c r} menu. + +@noindent +Available options are: + +@table @emph +@item @bullet{} Any-Frame +Display in the selected window of another existing frame +@item @bullet{} Current-Win +Display in the selected (current) window +@item @bullet{} Diff-Frame-One-Win +Display in the selected window of another existing frame, deleting its other windows +@item @bullet{} New-Frame +Display in a new single window frame +@item @bullet{} Other-Win +Display in another, possibly new window of the selected frame (this is +the default) +@item @bullet{} Single-Win +Display in a window of the selected frame and delete its other windows +@end table + +@page +@noindent +Alternatively, you can use the Hyperbole menubar menu as shown here: + +@float Image,image:Menu-Display-Referents +@caption{Display Referents Menu} +@image{im/menu-display-referents,6in,,Display Referents Menu} +@end float +@sp 1 + @xref{External Viewers}, for instructions on associating file names with external, window-system specific viewers. @@ -6592,6 +6608,9 @@ external, window-system specific viewers. @cindex external program @cindex external viewer @cindex link, viewer program + +@cindex external display +@vindex hpath:external-display-alist If you will be using Hyperbole under a window system, the @code{hpath:get-external-display-alist} function in @file{hpath.el} supports hyperlinks that open files using external, non-Emacs @@ -6750,9 +6769,11 @@ through invisible/hidden text, making the text temporarily visible until point moves past that hidden part. When a search match is selected, the surrounding text remains visible. -This command toggles that setting (turns it off if a prefix -argument less than or equal to 0 is given) and makes searches look at -only visible text. +You can temporarily disable searching of hidden text by typing {M-s i} +while in an incremental search. This key sequence toggles that +setting and makes searches look at only visible text (or the reverse +when invoked again). The setting lasts only through the current +interactive search. @node Button Colors, , Invisible Text Searches, Customization @subsection Configuring Button Colors