From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED.blaine.gmane.org!not-for-mail From: Michael Heerdegen Newsgroups: gmane.emacs.bugs Subject: bug#36566: 27.0.50; debug is sometimes horribly slow Date: Thu, 11 Jul 2019 00:46:00 +0200 Message-ID: <87r26xjyon.fsf@web.de> References: <87r26yvb4r.fsf@web.de> <871ryy2l1t.fsf@gmail.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: blaine.gmane.org; posting-host="blaine.gmane.org:195.159.176.226"; logging-data="189377"; mail-complaints-to="usenet@blaine.gmane.org" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.0.50 (gnu/linux) Cc: Gemini Lasswell , 36566@debbugs.gnu.org To: Noam Postavsky Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Thu Jul 11 00:47:35 2019 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([209.51.188.17]) by blaine.gmane.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.89) (envelope-from ) id 1hlLN7-000n5N-I3 for geb-bug-gnu-emacs@m.gmane.org; Thu, 11 Jul 2019 00:47:34 +0200 Original-Received: from localhost ([::1]:37524 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hlLN5-0000Zx-OW for geb-bug-gnu-emacs@m.gmane.org; Wed, 10 Jul 2019 18:47:31 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:47642) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hlLMf-0000WE-0j for bug-gnu-emacs@gnu.org; Wed, 10 Jul 2019 18:47:06 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hlLMc-0007w5-Ez for bug-gnu-emacs@gnu.org; Wed, 10 Jul 2019 18:47:03 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:56206) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hlLMb-0007vC-T6 for bug-gnu-emacs@gnu.org; Wed, 10 Jul 2019 18:47:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hlLMb-0004TV-PA for bug-gnu-emacs@gnu.org; Wed, 10 Jul 2019 18:47:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Michael Heerdegen Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 10 Jul 2019 22:47:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36566 X-GNU-PR-Package: emacs Original-Received: via spool by 36566-submit@debbugs.gnu.org id=B36566.156279877917144 (code B ref 36566); Wed, 10 Jul 2019 22:47:01 +0000 Original-Received: (at 36566) by debbugs.gnu.org; 10 Jul 2019 22:46:19 +0000 Original-Received: from localhost ([127.0.0.1]:36793 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hlLLs-0004SR-Tb for submit@debbugs.gnu.org; Wed, 10 Jul 2019 18:46:18 -0400 Original-Received: from mout.web.de ([212.227.15.4]:49183) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hlLLo-0004S9-9L for 36566@debbugs.gnu.org; Wed, 10 Jul 2019 18:46:15 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=web.de; s=dbaedf251592; t=1562798764; bh=S1LvJC5hPluuYtt4+dzxY5YDXV9k4IqrB6MwDU3Md0g=; h=X-UI-Sender-Class:From:To:Cc:Subject:References:Date:In-Reply-To; b=Kxg9RVnj55412eYZI9sodviWhDVUOvQGgISf5xSM/hmA2qVsuqQ3WAUyOWshXPKyi i4S3b58A0mIlOrT1tSZJYXoRIe4HN1bzODdUgolV1wewX5hCIAF9Y1IXk42yRcny/M HHkob9sneVTZghN4WPGGSPkhu5X58YQtQfnrnMWk= X-UI-Sender-Class: c548c8c5-30a9-4db5-a2e7-cb6cb037b8f9 Original-Received: from drachen.dragon ([92.208.178.213]) by smtp.web.de (mrweb001 [213.165.67.108]) with ESMTPSA (Nemesis) id 0MD8RQ-1hi1QN3TG0-00GYkx; Thu, 11 Jul 2019 00:46:03 +0200 In-Reply-To: <871ryy2l1t.fsf@gmail.com> (Noam Postavsky's message of "Wed, 10 Jul 2019 07:20:14 -0400") X-Provags-ID: V03:K1:jTuzF5es/XQl/+htLSSp1rvb1BN70XOjqhZYx2esw6sXrvR7cFR 4D2OadoZsUF1MW6Vc+HLMhJtxy6brQ6cLJs026tH4dHCb00qQjjB2W1Iv217Z3wFK8EQJg/ zLEl35xf0OAATbn5Ek/OBfD2VjHyH+a3CJXZhCcIPZDa8VgmEg+8x/B/YWfkPJg4G/dD69p eCdKkufp/1MBodY0f/3/Q== X-UI-Out-Filterresults: notjunk:1;V03:K0:wn5/YFH6gP4=:ZTu5BUwGoHAkCXKk3wzP2M xOQRqUFz2so/bENsIdMkpoStXSAMH36RvIBSwmktFE9yXroXW5jKTc/x9I/GPX3A44SVgQf4J BC6RBsiLrYpTrxIKr1uARIdx9lzfbx3sl9ssNaSEnPdVjip/newaqXbMsZQ2HOZDFvkFQW1nv /xPqn+ymiZukhGjN4I9M6WPbc0HOTwyNx78C8CTsNd1WjcIIm6Cayu+2eq+QPFwQQD2ugElcA Kl4N9FnZQ/tpNEp4a+CYGVLKLmlDfhsq2N9vD81ORKOD2BvG9YStb1sKDkGv2WYztW8ZeMfjF ej1iZrp5EH4Drzzasd3LdV3uNs3jWRcEB/w9kUusfFlyiwn4NCnWquyWCiLRh3IHdZ0Rq0keU pfgqtBTX14XQ1V3M+3uAXZA3P36UQH7fO7JRkRi/YT9+r4rSdyVcsnXxUcqTPNkq8GCuv6vgZ Jq/RC5txloBQUgO2ueGnak+2XYGyM4VIKoqj8NuSMU9mo+P4j30t+YCpYIS7eh9SYQxiMZulk BMlqp9Oi9TBoIy7Pvh9i+5JPnq6pNkFLaXn0Y6HJGc2D68r+wvQ9FvosBOGVAagyAjSZMAPBF CNDiAvZAjzEh3nYOzwSDOprtug0MQACX8mzeIYaXdlCG0x7iCwZT0q/wOjMPVvTAc8rOuDxzX 225ZrBEOSdk6QvEN4wgpwS/Tvu3xM5n/PCeKbDcqrfyIfIfjGh8S2TcmIQip0FDgCQBJTSkFs TOZqNBEJ+siYc7cI7y0geQyLmv1H4qYjYucqSOjcO81VIhkhbngbkd17cbIY9IuzrfWrOwgo X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:162666 Archived-At: --=-=-= Content-Type: text/plain Noam Postavsky writes: > > sometimes it takes 10 or 20 seconds until the debugger pops up. I > > debugged code using widgets (who are complicated long lists). But both > > the number of frames and the length of the printed lists were not > > exorbitant - a quite normal situation. > > Can you give an example recipe that produces the slowness? It's not > usually slow, right? (When I trigger the debugger in master right now, > I don't notice problem.) I investigated a bit and found that the main factor of the sluggishness seems to be my private (global) setting of print-gensym -> t: I can toggle sluggishness in both the Emacs with my setup and emacs -Q just by toggling this variable. My debugger use case involves gensyms (see later). Ok, so it's probably mainly a printing issue. Here is my use case: load the attached file (don't compile, I made it contain a bug). M-x find-cmd-widget, and insert a "links" expression by hitting the INS button and select "links" with the "expr" button. With print-gemsym -> nil, the debugger needs approx. 2 seconds here to pop up, and with print-gemsym -> t, approx. 12. So I wonder why this setting makes it that slow - I would expect a small time penalty, but such a big difference? BTW, extra points if the debugger provided commands/ a menu to tune such settings (like printing variables) live when using it. --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=find-cmd-widget.el Content-Transfer-Encoding: quoted-printable ;;; find-cmd-widget.el --- Build a valid find(1) command with widgets -*- l= exical-binding: t -*- ;; Copyright (C) 2019 Free Software Foundation, Inc ;; Author: Michael Heerdegen ;; Maintainer: Michael Heerdegen ;; Created: 10 Jun 2019 ;; Keywords: convenience ;; Compatibility: GNU Emacs 26 ;; Version: 0.1 ;; Package-Requires: ((emacs "26")) ;; This file is not part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . ;;; Commentary: ;; ... ;;; Code: ;;;; Requirements (require 'widget) (require 'find-cmd) (require 'subr-x) (require 'cus-edit) (eval-when-compile (require 'wid-edit)) ;;;; Variables (defvar find-cmd-widget-find-arg-alist ;; elements are (symbol make-widget-fun category annotation hint-string) ;; 0 1 2 3 4 '( ;; generic tests (amin find-cmd-widget-make-time-minutes-widget "Tests" "Minutes since file last accessed") (anewer find-cmd-widget-make-xnewer-widget "Tests" "Last accessed more recently than a specified file was modi= fied") (atime find-cmd-widget-make-time-days-widget "Tests" "Days since file last accessed (rounded down; see also `day= start`)") (cmin find-cmd-widget-make-time-minutes-widget "Tests" "Minutes since last status change") (cnewer find-cmd-widget-make-xnewer-widget "Tests" "Status changed more recently than a specified file was mod= ified") (ctime find-cmd-widget-make-time-days-widget "Tests" "Days since last status change (rounded down; see also `day= start`)") (empty find-cmd-widget-make-choice-widget "Tests" "Empty regular file or directory") (executable find-cmd-widget-make-choice-widget "Tests" "File is executable/ Dir is searchable") (false find-cmd-widget-make-choice-widget "Tests" "Always false") (fstype find-cmd-widget-make-editable-field-widget "Tests") (gid find-cmd-widget-make-editable-field-widget "Tests") (group find-cmd-widget-make-editable-field-widget "Tests") (ilname find-cmd-widget-make-lname-widget "Tests" "Case insensitive version of `lname`" "shell glob pattern; must match the complete name") (iname find-cmd-widget-make-editable-field-widget "Tests" "Like `name` but match is case insensitive" "shell glob pattern; must match the complete name") (inum find-cmd-widget-make-editable-field-widget "Tests") (ipath find-cmd-widget-make-editable-field-widget "Tests" "Like `path` but match is case insensitive" "shell glob pattern; must match the complete path") (iregex find-cmd-widget-make-editable-field-widget "Tests") ;; (iwholename (1) "tests") ; same as `ipath` (links find-cmd-widget-make-links-widget "Tests" "Number of hard links") (lname find-cmd-widget-make-lname-widget "Tests" "symlink whose contents match a shell pattern" "shell glob pattern; must match the complete name") (mmin find-cmd-widget-make-time-minutes-widget "Tests" "Minutes since last data change") (mtime find-cmd-widget-make-time-days-widget "Tests" "Days since last data change (rounded down; see also `dayst= art`)") (name find-cmd-widget-make-editable-field-widget "Tests" "Match shell pattern against base of file name" "shell glob pattern; must match the complete name") (newer find-cmd-widget-make-editable-field-widget "Tests") (nogroup find-cmd-widget-make-choice-widget "Tests" "No group corresponds to file's numeric group ID") (nouser find-cmd-widget-make-choice-widget "Tests" "No user corresponds to file's numeric user ID") (path find-cmd-widget-make-editable-field-widget "Tests" "Match shell pattern against complete file name" "shell glob pattern; must match the complete path") (perm find-cmd-widget-make-choice-widget "Tests") (readable find-cmd-widget-make-choice-widget "Tests" "Readabl= e file") (regex find-cmd-widget-make-editable-field-widget "Tests") (samefile find-cmd-widget-make-editable-field-widget "Tests") (size find-cmd-widget-make-editable-field-widget "Tests") (true find-cmd-widget-make-choice-widget "Tests" "Always = true") (type find-cmd-widget-make-type-widget "Tests" "File Ty= pe") (uid find-cmd-widget-make-editable-field-widget "Tests") (used find-cmd-widget-make-editable-field-widget "Tests") (user find-cmd-widget-make-editable-field-widget "Tests" "File owned by specified user" "numeric user ID allowed") ;; (wholename (1) "tests") ; same as `path` (writable find-cmd-widget-make-choice-widget "Tests" "Writabl= e file") (xtype find-cmd-widget-make-type-widget "Tests" "File or= link target type") ;; normal options (always true) (daystart find-cmd-widget-make-choice-widget "Opti= ons") (depth find-cmd-widget-make-choice-widget "Opti= ons") (maxdepth find-cmd-widget-make-editable-field-widget "Opti= ons") (mindepth find-cmd-widget-make-editable-field-widget "Opti= ons") (mount find-cmd-widget-make-choice-widget "Opti= ons") (noleaf find-cmd-widget-make-choice-widget "Opti= ons") (ignore_readdir_race find-cmd-widget-make-choice-widget "Opti= ons") (noignore_readdir_race find-cmd-widget-make-choice-widget "Opti= ons") (regextype find-cmd-widget-make-editable-field-widget "Opti= ons") (xdev find-cmd-widget-make-choice-widget "Opti= ons") (and find-cmd-widget-make-combiner-widget "Combiners") (not find-cmd-widget-make-combiner-widget "Combiners") (or find-cmd-widget-make-combiner-widget "Combiners") (prune find-cmd-widget-make-combiner-widget "Combiners") ;; actions (delete find-cmd-widget-make-choice-widget "Actions") (print0 find-cmd-widget-make-choice-widget "Actions") (printf find-cmd-widget-make-editable-field-widget "Actions") (fprintf find-cmd-widget-make-editable-field-widget "Actions") ;fixme: = gets two args! (print find-cmd-widget-make-choice-widget "Actions") (fprint0 find-cmd-widget-make-editable-field-widget "Actions") (fprint find-cmd-widget-make-editable-field-widget "Actions") (ls find-cmd-widget-make-choice-widget "Actions") (fls find-cmd-widget-make-editable-field-widget "Actions") (prune find-cmd-widget-make-choice-widget "Actions") (quit find-cmd-widget-make-choice-widget "Actions") ;; these need to be terminated with a ; (exec find-cmd-widget-make-editable-field-widget "Actions") (ok find-cmd-widget-make-editable-field-widget "Actions") (execdir find-cmd-widget-make-editable-field-widget "Actions") (okdir find-cmd-widget-make-editable-field-widget "Actions")) "Doc...") (defvar find-cmd-widget-find-global-option-arglist '(;; switches (L find-cmd-widget-make-choice-widget "Switches") (P find-cmd-widget-make-choice-widget "Switches") (H find-cmd-widget-make-choice-widget "Switches")) "Doc...") (defvar-local find-cmd-widget-main-widget nil) (defvar-local find-cmd-widget-preview-widget-1 nil) (defvar-local find-cmd-widget-preview-widget-2 nil) (defvar-local find-cmd-widget-warning-widget nil) (defvar-local find-cmd-widget-current-global-option nil) (defvar-local find-cmd-widget-warnings '()) ;;;; Helpers (defun find-cmd-widget--just-true (_) t) (defun find-cmd-widget--warn-arg-not-implemented (arg) (when arg (warn "Argument not implemented"))) (defun find-cmd-widget--parse-widget-sexp (sexp) `(,@(when-let ((opt (car sexp))) `(,opt)) ,@(cadr sexp))) (defun find-cmd-widget-create-find-cmd (sexp) `(find-cmd ,(find-cmd-widget--parse-widget-sexp (cdr sexp)))) (defun find-cmd-widget-find-call-get-dir+exps (sexp) (list (car sexp) (mapconcat #'find-to-string (find-cmd-widget--parse-widget-sexp (cd= r sexp)) ""))) (defun find-cmd-widget--build-dirs-string (dirs &optional no-shell-quote) (mapconcat (if no-shell-quote #'identity #'shell-quote-argument) (mapcar #'expand-file-name dirs) " ")) (defun find-cmd-widget-create-find-call (sexp) ;; We do that manually because `find-cmd' doesn't yet handle multiple ;; search paths (let* ((dirs+exps (find-cmd-widget-find-call-get-dir+exps sexp)) (dirs (car dirs+exps))) (concat find-program (if dirs (concat " " (concat (find-cmd-widget--build-dirs-string dir= s))) "") " " (cadr dirs+exps)))) (defun find-cmd-widget-menu-choice-action (&rest args) (cl-letf (((symbol-function #'widget-choose) #'find-cmd-widget--widget-choose)) ;; this doesn't notify the parent widget, but it should (apply #'widget-choice-action args))) (defun find-cmd-widget--widget-choose (title items &optional event) (let ((widget-menu-max-size 100)) (if event ;; mouse click (let* (chosen-item (make-item (lambda (i) (let* ((s (car i)) (e (assoc (intern s) find-cmd-widget-find-arg-alis= t))) (vector s (lambda () (interactive) (setq chosen-item (c= dr i))) :help (nth 3 e)))))) (popup-menu `(,title (keymap ("By category" ,@(mapcar (pcase-lambda (`(,cat . ,items)) `(,cat ,@(mapcar make-item items))) (seq-group-by (lambda (item) (nth 2 (assoc (intern (car item)) find-cmd-widget-find= -arg-alist))) items))) ,@(mapcar make-item (cl-sort items #'string< :key #'car)))) event) chosen-item) (setq items (cl-remove-if 'stringp items)) (let* ((max-item-length (apply #'max (mapcar (lambda (e) (length (symbol-na= me (car e)))) find-cmd-widget-find-arg-alist= ))) (max-cat-length (apply #'max (mapcar #'length (mapcar #'caddr find-= cmd-widget-find-arg-alist)))) (completions-format 'vertical) (val (completing-read (concat title ": ") (lambda (string pred action) (if (eq action 'metadata) `(metadata (display-sort-function . ,#'identity) (annotation-function . ,(lambda (s) (when-let ((entry (assoc (intern-soft s) find-cmd-widget-fin= d-arg-alist))) (let ((category (nth 2 entry)) (description (nth 3 entry))) (and (or category description) (concat (make-string (- max-item-le= ngth (length s)) ?\ ) (format "[%s]" category) (make-string (- max-cat-length (length = category)) ?\ ) (if description description= "")))))))) (complete-with-action action items string pred))) nil t))) (if (stringp val) (let ((try (try-completion val items))) (when (stringp try) (setq val try)) (cdr (assoc val items)))))))) (defun find-cmd-widget--value-get-1 (command) (lambda (w) (list command (widget-field-value-get w)))) (defalias 'find-cmd-widget--get-arg (pcase-lambda ((and `(,name ,(and (pred functionp) make-widget) . ,rest) (let hint (nth 2 rest)))) (ignore rest) (funcall make-widget name hint))) (defun find-cmd-widget-find-action (&rest _) (interactive) (async-shell-command (widget-value find-cmd-widget-preview-widget-2))) (defun find-cmd-widget-find-dired-action (&rest _) (interactive) (let ((args (find-cmd-widget-find-call-get-dir+exps (widget-value find-cm= d-widget-main-widget)))) (when (cdr (car args)) (user-error "find-dired currently supports only one path, sorry")) (setf (car args) (if (car args) (find-cmd-widget--build-dirs-string (ca= r args) 'no-quote) ".")) (apply #'find-dired args))) ;;;; Widget definitions (define-widget 'find-cmd-preview 'item "Doc..." :format "%v" :value-face 'highlight :value-create #'widget-field-value-create ;; (lambda (w) ;; (insert (propertize (widget-get w :value) 'face 'success))) ) (defvar find-cmd-widget-sign-args (mapcar (pcase-lambda (`(,sign ,descr ,val)) (cons sign `(choice-item :tag ,descr :value-inline ,(lambda (_w) `(,val))))) '((< "less than" "-") (> "greater than" "+") (=3D "exactly" "")))) (define-widget 'find-cmd-widget-sign 'menu-choice "Doc..." :format "sign: %v" :args (mapcar #'cdr find-cmd-widget-sign-args)) (defun find-cmd-widget-make-choice-widget (name hint) (find-cmd-widget--warn-arg-not-implemented hint) `(choice-item :tag ,(symbol-name name) :value-get ,(lambda (_w) (list name)))) (define-widget 'find-cmd-widget-editable-field 'editable-field "Doc..." :size 2 :validate #'find-cmd-widget--just-true :value-get (lambda (w) (list (intern (widget-get w :menu-tag)) (widget-fi= eld-value-get w))) :keymap widget-field-keymap) (defun find-cmd-widget-make-editable-field-widget (name &optional hint) (let ((name-string (symbol-name name))) `(find-cmd-widget-editable-field :menu-tag ,name-string :format ,(concat name-string ": %v" (and hint (format " (%s)" hint))= "\n")))) (defun find-cmd-widget-make-lname-widget (name &optional hint) (let ((name-string (symbol-name name))) `(find-cmd-widget-editable-field :menu-tag ,name-string :format ,(concat name-string ": %v" (and hint (format " (%s)" hint))= "\n") :value-get ,(lambda (w) (when (eq 'L (car find-cmd-widget-current-global-option)) (push (format "Global option \"-L\" and \"-%s\" used together" n= ame-string) find-cmd-widget-warnings)) (list name (widget-field-value-get w)))))) (define-widget 'find-cmd-widget-n 'find-cmd-widget-editable-field "Widget to input find(1) n option arguments.") (defun find-cmd-widget-make-n-widget (tag &optional hint) `(find-cmd-widget-n :menu-tag ,tag :format ,(concat tag ": %v" (and hint (format " (%s)" hint)) "\n"))) (defun find-cmd-widget-make-signed-n-widget (name hint unit &optional defau= lt-sign) (find-cmd-widget--warn-arg-not-implemented hint) (let ((sname (symbol-name name))) `(group :tag ,sname :format ,(format "%s [%s]\n%%v" sname (nth 3 (assoc name find-cmd-widget-find-arg-alist))) :value-get ,(lambda (w) `(,name ,(apply #'concat (widget-editable-lis= t-value-get w)))) :args ((find-cmd-widget-sign ,@(and default-sign `(:explicit-choice ,(assoc default-sign find-cm= d-widget-sign-args)))) ,(let ((w (find-cmd-widget-make-n-widget unit nil))) (widget-put w :value-get #'widget-field-value-get) w))))) (defun find-cmd-widget-make-time-days-widget (name hint) (find-cmd-widget-make-signed-n-widget name hint "days" '<)) (defun find-cmd-widget-make-time-minutes-widget (name hint) (find-cmd-widget-make-signed-n-widget name hint "minutes" '<)) (defun find-cmd-widget-make-links-widget (name hint) (find-cmd-widget-make-signed-n-widget name hint "links" '=3D)) (defun find-cmd-widget-make-type-widget (name hint) (find-cmd-widget--warn-arg-not-implemented hint) (cl-flet ((vget (s) (lambda (_w) (list (list s))))) `(checklist :tag ,(symbol-name name) :format "file type:\n%v" :value-get ;; validate here since :validate it tricky ,(lambda (w) (let ((v (widget-checklist-value-get w))) (when (and (eq name 'type) (eq 'L (car find-cmd-widget-current-global-= option)) (seq-some (lambda (x) (string=3D (car x) "l= ")) v)) (push "Global option \"-L\"- and -type l (\"symbolic= link\") used together" find-cmd-widget-warnings)) `(,name ,(mapconcat #'car v ",")))) :args ((choice-item :tag "regular file" := value-inline ,(vget "f")) (choice-item :tag "directory" := value-inline ,(vget "d")) (choice-item :tag "symbolic link" := value-inline ,(vget "l")) (choice-item :tag "block (buffered) special" := value-inline ,(vget "b")) (choice-item :tag "character (unbuffered) special" := value-inline ,(vget "c")) (choice-item :tag "named pipe (FIFO)" := value-inline ,(vget "p")) (choice-item :tag "socked" := value-inline ,(vget "s")) (choice-item :tag "door (Solaris)" := value-inline ,(vget "D")))))) (defun find-cmd-widget-make-combiner-widget (combiner hint) (find-cmd-widget--warn-arg-not-implemented hint) (let ((sname (symbol-name combiner))) `(find-expr :tag ,sname :format ,(concat sname "\n%v") :value-inline ,(lambda (w) `((,combiner ,@(widget-child-val= ue-get w))))))) (define-widget 'find-cmd-widget-file-widget 'item "Doc..." :action (lambda (w &rest _) (widget-value-set w (funcall (widget-get w :read-file-name-fun)= w)) (widget-apply w :notify w)) :read-file-name-fun (lambda (w) (read-file-name "Dir: " nil (widget-value= -value-get w))) :value "") ;; FIXME: Doesn't work (defun find-cmd-widget-make-xnewer-widget (name hint) `(find-cmd-widget-file-widget :value-get ,(lambda (w) `(,name ,(expand-file-name (widget-value-value-= get w)))) :tag ,(symbol-name name) :format ,(concat "%[file%]: %v" (when hint (format " [%s]" hin= t)) "\n"))) (define-widget 'find-expr 'lazy "Doc..." :format "...:\n%v" :type `(editable-list ;; :entry-format "%i\n%d %v" ;; that breaks intendation; %n not ;; implemented in `widget-editable-list-entry-create' :-( :args ((menu-choice :tag "expr" :explicit-choice ,(find-cmd-widget--get-arg (assoc 'iname find-= cmd-widget-find-arg-alist)) :value "*" :action find-cmd-widget-menu-choice-action :args ,(mapcar #'find-cmd-widget--get-arg find-cmd-widget-find-= arg-alist))))) (define-widget 'find-cmd-widget-global-option 'menu-choice "Doc..." :format "global options: %v\n" :action 'find-cmd-widget-menu-choice-action :notify (lambda (w &rest args) (setq find-cmd-widget-current-global-option (widget-value w)) (apply #'widget-default-notify w args)) :args (cons `(choice-item :tag "none" :value-get ,(lambda (_w) nil)) (mapcar #'find-cmd-widget--get-arg find-cmd-widget-find-global-option-arglist))) (define-widget 'find 'group "Doc..." :format "%v" :value-get (lambda (w) (setq find-cmd-widget-warnings '()) (widget-editable-list-value-get w)) :notify (pcase-lambda ((app widget-value v) &rest _) (widget-value-set find-cmd-widget-preview-widget-1 (string-trim-right (pp-to-string (find-cmd-widget-create-find-cmd v)))) (widget-value-set find-cmd-widget-preview-widget-2 (find-cmd-widget-create-find-call v)) (widget-value-set find-cmd-widget-warning-widget (if find-cmd-widget-warnings (mapconcat (apply-partially #'concat "Warning: ") find-cmd-widget-warnings "\n") ""))) :args `((editable-list :format "paths:\n%v%i\n" :args ((find-cmd-widget-file-widget :format "find %[path%]: %v\n" ;; initialize VALUE dynamically: :convert-widget ,(lambda (widget) (widget-put widget :value default-directory) (widget-put widget :args nil) widget) :read-file-name-fun ,(lambda (w) (read-directory-name "Dir: " (widge= t-value w)))))) (find-cmd-widget-global-option) (find-expr :format "expressions:\n%v"))) ;;;; Main commands ;;;###autoload (defun find-cmd-widget () "Doc..." (interactive) (let ((buf (generate-new-buffer "*Widget Find*"))) (pop-to-buffer buf) (kill-all-local-variables) (let ((inhibit-read-only t)) (erase-buffer)) (remove-overlays) (custom--initialize-widget-variables) (setq-local find-cmd-widget-main-widget (widget-create 'find)) (setq-local find-cmd-widget-warning-widget (widget-create 'find-cmd-preview :value "" :value-face 'error)) (let ((arrow ?=E2=87=A9)) (when (char-displayable-p arrow) (insert (propertize (concat " " (string arrow)) 'face '(:height = 2.0)) "\n")) (setq-local find-cmd-widget-preview-widget-1 (widget-create 'find-cmd-preview :value "Here will appear a `find-cmd' prev= iew")) (insert " ") (widget-create 'push-button :tag "Copy!" :help-echo "Copy `find-cmd' call to kill ring" :action (lambda (&rest _) (let ((s (widget-value find-cmd-widget-previ= ew-widget-1))) (kill-new s) (message "%s" s)))) (insert "\n") (when (char-displayable-p arrow) (insert (propertize (concat " " (string arrow)) 'face '(:height = 2.0)) "\n")) (setq-local find-cmd-widget-preview-widget-2 (widget-create 'find-cmd-preview :value "\ Here will appear a preview for the constructed find(1) call")) (insert " ") (widget-create 'push-button :tag "Copy!" :help-echo "Copy \"find\" call to kill ring" :action (lambda (&rest _) (let ((s (widget-value find-cmd-widget-previ= ew-widget-2))) (kill-new s) (message "%s" s))))) (insert "\n\n\n") (widget-create 'push-button :tag "find!" :help-echo "Run constructed find command" :action #'find-cmd-widget-find-action) (insert " ") (widget-create 'push-button :tag "find-dired!" :help-echo "Run constructed find command as find-dired" :action #'find-cmd-widget-find-dired-action) (insert "\n") (use-local-map (let ((map (make-sparse-keymap))) (set-keymap-parent map widget-keymap) (define-key map [(control ?c) (control ?c)] #'find-cmd-widget-find-dired-action) map)) (widget-setup) (goto-char (point-min)))) (provide 'find-cmd-widget) ;;; find-cmd-widget.el ends here --=-=-= Content-Type: text/plain Thanks, Michael. --=-=-=--