forge-commands.el (43893B)
1 ;;; forge-commands.el --- Commands -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2018-2022 Jonas Bernoulli 4 5 ;; Author: Jonas Bernoulli <jonas@bernoul.li> 6 ;; Maintainer: Jonas Bernoulli <jonas@bernoul.li> 7 ;; SPDX-License-Identifier: GPL-3.0-or-later 8 9 ;; This file is not part of GNU Emacs. 10 11 ;; Forge is free software; you can redistribute it and/or modify it 12 ;; under the terms of the GNU General Public License as published by 13 ;; the Free Software Foundation; either version 3, or (at your option) 14 ;; any later version. 15 ;; 16 ;; Forge is distributed in the hope that it will be useful, but WITHOUT 17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 18 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public 19 ;; License for more details. 20 ;; 21 ;; You should have received a copy of the GNU General Public License 22 ;; along with Forge. If not, see http://www.gnu.org/licenses. 23 24 ;;; Code: 25 26 (require 'forge) 27 28 ;;; Options 29 30 (defcustom forge-add-pullreq-refspec t 31 "Whether the pull-request refspec is added when setting up a repository. 32 33 This controls whether running `forge-pull' for the first time in 34 a repository also adds a refspec that fetches all pull-requests. 35 In repositories with huge numbers of pull-requests you might want 36 to not do so, in which case you should set this option to `ask'. 37 38 You can also set this to nil and later add the refspec explicitly 39 for a repository using the command `forge-add-pullreq-refspec'." 40 :package-version '(forge . "0.2.0") 41 :group 'forge 42 :type '(choice (const :tag "Always add refspec" t) 43 (const :tag "Ask every time" ask) 44 (const :tag "Never add refspec" nil))) 45 46 (defcustom forge-checkout-worktree-read-directory-function 47 'forge-checkout-worktree-default-read-directory-function 48 "Function used by `forge-checkout-worktree' to read worktree directory. 49 Takes the pull-request as only argument and must return a directory." 50 :package-version '(forge . "0.4.0") 51 :group 'forge 52 :type 'function) 53 54 ;;; Dispatch 55 56 ;;;###autoload (autoload 'forge-dispatch "forge-commands" nil t) 57 (transient-define-prefix forge-dispatch () 58 "Dispatch a forge command." 59 [["Fetch" 60 ("f f" "all topics" forge-pull) 61 ("f t" "one topic" forge-pull-topic) 62 ("f n" "notifications" forge-pull-notifications) 63 """Create" 64 ("c i" "issue" forge-create-issue) 65 ("c p" "pull-request" forge-create-pullreq) 66 ("c u" "pull-request from issue" forge-create-pullreq-from-issue 67 :if (lambda () (forge-github-repository-p (forge-get-repository nil)))) 68 ("c f" "fork or remote" forge-fork) 69 """Merge" 70 (7 "M " "merge using API" forge-merge)] 71 ["List" 72 ("l t" "topics" forge-list-topics) 73 ("l i" "issues" forge-list-issues) 74 ("l p" "pull-requests" forge-list-pullreqs) 75 ("l n" "notifications" forge-list-notifications) 76 ("l r" "repositories" forge-list-repositories) 77 (7 "l a" "awaiting review" forge-list-requested-reviews) 78 (7 "n i" "labeled issues" forge-list-labeled-issues) 79 (7 "n p" "labeled pull-requests" forge-list-labeled-pullreqs) 80 (7 "m i" "authored issues" forge-list-authored-issues) 81 (7 "m p" "authored pull-requests" forge-list-authored-pullreqs) 82 (7 "o i" "owned issues" forge-list-owned-issues) 83 (7 "o p" "owned pull-requests" forge-list-owned-pullreqs) 84 (7 "o r" "owned repositories" forge-list-owned-repositories)] 85 ["Visit" 86 ("v t" "topic" forge-visit-topic) 87 ("v i" "issue" forge-visit-issue) 88 ("v p" "pull-request" forge-visit-pullreq) 89 """Browse" 90 ("b I" "issues" forge-browse-issues) 91 ("b P" "pull-requests" forge-browse-pullreqs) 92 ("b t" "topic" forge-browse-topic) 93 ("b i" "issue" forge-browse-issue) 94 ("b p" "pull-request" forge-browse-pullreq)]] 95 [["Configure" 96 ("a " "add repository to database" forge-add-repository) 97 ("r " "forge.remote" forge-forge.remote) 98 ("t t" forge-toggle-display-in-status-buffer) 99 ("t c" forge-toggle-closed-visibility)]]) 100 101 ;;; Pull 102 103 ;;;###autoload 104 (defun forge-pull (&optional repo until) 105 "Pull topics from the forge repository. 106 107 With a prefix argument and if the repository has not been fetched 108 before, then read a date from the user and limit pulled topics to 109 those that have been updated since then. 110 111 If pulling is too slow, then also consider setting the Git variable 112 `forge.omitExpensive' to `true'." 113 (interactive 114 (list nil 115 (and current-prefix-arg 116 (not (forge-get-repository 'full)) 117 (forge-read-date "Limit pulling to topics updates since: ")))) 118 (let (create) 119 (unless repo 120 (setq repo (forge-get-repository 'full)) 121 (unless repo 122 (setq repo (forge-get-repository 'create)) 123 (setq create t))) 124 (when (or create 125 (called-interactively-p 'any) 126 (magit-git-config-p "forge.autoPull" t)) 127 (forge--zap-repository-cache repo) 128 (when (and (oref repo selective-p) 129 (called-interactively-p 'any) 130 (yes-or-no-p 131 (format "Always pull all of %s/%s's topics going forward?" 132 (oref repo owner) 133 (oref repo name)))) 134 (oset repo selective-p nil)) 135 (setq forge--mode-line-buffer (current-buffer)) 136 (when-let ((remote (oref repo remote)) 137 (refspec (oref repo pullreq-refspec))) 138 (when (and create 139 (not (member refspec (magit-get-all "remote" remote "fetch"))) 140 (or (eq forge-add-pullreq-refspec t) 141 (and (eq forge-add-pullreq-refspec 'ask) 142 (y-or-n-p (format "Also add %S refspec? " refspec))))) 143 (magit-call-git "config" "--add" 144 (format "remote.%s.fetch" remote) 145 refspec))) 146 (forge--msg repo t nil "Pulling REPO") 147 (forge--pull repo until)))) 148 149 (defun forge-read-date (prompt) 150 (cl-block nil 151 (while t 152 (let ((str (read-from-minibuffer prompt))) 153 (cond ((string-equal str "") 154 (cl-return nil)) 155 ((string-match-p 156 "\\`[0-9]\\{4\\}[-/][0-9]\\{2\\}[-/][0-9]\\{2\\}\\'" str) 157 (cl-return str)))) 158 (message "Please enter a date in the format YYYY-MM-DD.") 159 (sit-for 1)))) 160 161 (cl-defmethod forge--pull ((repo forge-noapi-repository) _until) ; NOOP 162 (forge--msg repo t t "Pulling from REPO is not supported")) 163 164 (cl-defmethod forge--pull ((repo forge-unusedapi-repository) _until) 165 (oset repo sparse-p nil) 166 (magit-git-fetch (oref repo remote) (magit-fetch-arguments))) 167 168 (defun forge--git-fetch (buf dir repo) 169 (if (buffer-live-p buf) 170 (with-current-buffer buf 171 (magit-git-fetch (oref repo remote) (magit-fetch-arguments))) 172 (let ((default-directory dir)) 173 (magit-git-fetch (oref repo remote) (magit-fetch-arguments))))) 174 175 ;;;###autoload 176 (defun forge-pull-notifications () 177 "Fetch notifications for all repositories from the current forge." 178 (interactive) 179 (let* ((repo (forge-get-repository 'stub)) 180 (class (eieio-object-class repo))) 181 (if (eq class 'forge-github-repository) 182 (forge--pull-notifications class (oref repo githost)) 183 (user-error "Fetching notifications not supported for forge %S" 184 (oref repo forge))))) 185 186 ;;;###autoload 187 (defun forge-pull-topic (topic) 188 "Pull the API data for the current topic. 189 If there is no current topic or with a prefix argument read a 190 TOPIC to pull instead." 191 (interactive (list (forge-read-topic "Pull topic" nil t))) 192 (let ((repo (forge-get-repository t))) 193 (forge--zap-repository-cache repo) 194 (forge--pull-topic repo 195 (if (numberp topic) 196 (forge-issue :repository (oref repo id) 197 :number topic) 198 (forge-get-topic topic))))) 199 200 (cl-defmethod forge--pull-topic ((repo forge-repository) _topic) 201 (error "Fetching an individual topic not implemented for %s" 202 (eieio-object-class repo))) 203 204 (defun forge--zap-repository-cache (&optional repo) 205 (when-let ((r (if repo 206 (oref repo worktree) 207 (magit-repository-local-repository)))) 208 (magit-repository-local-delete (list 'forge-ls-recent-topics 'issue) r) 209 (magit-repository-local-delete (list 'forge-ls-recent-topics 'pullreq) r))) 210 211 ;;; Browse 212 213 ;;;###autoload 214 (defun forge-browse-dwim () 215 "Visit a topic, branch or commit using a browser. 216 Prefer a topic over a branch and that over a commit." 217 (interactive) 218 (if-let ((topic (forge-topic-at-point))) 219 (forge-browse topic) 220 (if-let ((branch (magit-branch-at-point))) 221 (forge-browse-branch branch) 222 (call-interactively 'forge-browse-commit)))) 223 224 ;;;###autoload 225 (defun forge-browse-commit (rev) 226 "Visit the url corresponding to REV using a browser." 227 (interactive 228 (list (or (magit-completing-read "Browse commit" 229 (magit-list-branch-names) 230 nil nil nil 'magit-revision-history 231 (magit-branch-or-commit-at-point)) 232 (user-error "Nothing selected")))) 233 (let ((repo (forge-get-repository 'stub))) 234 (unless (magit-list-containing-branches 235 rev "-r" (concat (oref repo remote) "/*")) 236 (if-let ((branch (car (magit-list-containing-branches rev "-r")))) 237 (setq repo (forge-get-repository 238 'stub (cdr (magit-split-branch-name branch)))) 239 (message "%s does not appear to be available on any remote. %s" 240 rev "You might have to push it first."))) 241 (browse-url 242 (forge--format repo 'commit-url-format 243 `((?r . ,(magit-commit-p rev))))))) 244 245 ;;;###autoload 246 (defun forge-copy-url-at-point-as-kill () 247 "Copy the url of the thing at point." 248 (interactive) 249 (if-let ((url (forge-get-url (or (forge-post-at-point) 250 (forge-current-topic))))) 251 (progn 252 (kill-new url) 253 (message "Copied %S" url)) 254 (user-error "Nothing at point with a URL"))) 255 256 ;;;###autoload 257 (defun forge-browse-branch (branch) 258 "Visit the url corresponding BRANCH using a browser." 259 (interactive (list (magit-read-branch "Browse branch"))) 260 (let (remote) 261 (if (magit-remote-branch-p branch) 262 (let ((cons (magit-split-branch-name branch))) 263 (setq remote (car cons)) 264 (setq branch (cdr cons))) 265 (or (setq remote (or (magit-get-push-remote branch) 266 (magit-get-upstream-remote branch))) 267 (user-error "Cannot determine remote for %s" branch))) 268 (browse-url (forge--format remote 'branch-url-format 269 `((?r . ,branch)))))) 270 271 ;;;###autoload 272 (defun forge-browse-remote (remote) 273 "Visit the url corresponding to REMOTE using a browser." 274 (interactive (list (magit-read-remote "Browse remote"))) 275 (browse-url (forge--format remote 'remote-url-format))) 276 277 ;;;###autoload 278 (defun forge-browse-repository (repo) 279 "View the current repository in a separate buffer." 280 (interactive 281 (list (or (forge-current-repository) 282 (forge-get-repository 283 (forge-read-repository "Browse repository"))))) 284 (browse-url (forge--format repo 'remote-url-format))) 285 286 ;;;###autoload 287 (defun forge-browse-topic () 288 "Visit the current topic using a browser." 289 (interactive) 290 (if-let ((topic (forge-current-topic))) 291 (forge-browse topic) 292 (user-error "There is no current topic"))) 293 294 ;;;###autoload 295 (defun forge-browse-pullreqs () 296 "Visit the pull-requests of the current repository using a browser." 297 (interactive) 298 (browse-url (forge--format (forge-get-repository 'stub) 299 'pullreqs-url-format))) 300 301 ;;;###autoload 302 (defun forge-browse-pullreq (pullreq) 303 "Visit the url corresponding to PULLREQ using a browser." 304 (interactive (list (forge-read-pullreq "Browse pull-request" t))) 305 (forge-browse (forge-get-pullreq pullreq))) 306 307 ;;;###autoload 308 (defun forge-browse-issues () 309 "Visit the issues of the current repository using a browser." 310 (interactive) 311 (browse-url (forge--format (forge-get-repository 'stub) 312 'issues-url-format))) 313 314 ;;;###autoload 315 (defun forge-browse-issue (issue) 316 "Visit the current issue using a browser. 317 If there is no current issue or with a prefix argument 318 read an ISSUE to visit." 319 (interactive (list (forge-read-issue "Browse issue" t))) 320 (forge-browse (forge-get-issue issue))) 321 322 ;;;###autoload 323 (defun forge-browse-post () 324 "Visit the current post using a browser." 325 (interactive) 326 (if-let ((post (forge-post-at-point))) 327 (forge-browse post) 328 (user-error "There is no current post"))) 329 330 ;;; Visit 331 332 ;;;###autoload 333 (defun forge-visit-topic (topic) 334 "View the current topic in a separate buffer. 335 If there is no current topic or with a prefix argument 336 read a topic to visit instead." 337 (interactive (list (if-let ((topic (forge-current-topic))) 338 (oref topic id) 339 (forge-read-topic "View topic")))) 340 (forge-visit (forge-get-topic topic))) 341 342 ;;;###autoload 343 (defun forge-visit-pullreq (pullreq) 344 "View the current pull-request in a separate buffer. 345 If there is no current pull-request or with a prefix argument 346 read a PULLREQ to visit instead." 347 (interactive (list (forge-read-pullreq "View pull-request" t))) 348 (forge-visit (forge-get-pullreq pullreq))) 349 350 ;;;###autoload 351 (defun forge-visit-issue (issue) 352 "Visit the current issue in a separate buffer. 353 If there is no current issue or with a prefix argument 354 read an ISSUE to visit instead." 355 (interactive (list (forge-read-issue "View issue" t))) 356 (forge-visit (forge-get-issue issue))) 357 358 ;;;###autoload 359 (defun forge-visit-repository (repo) 360 "View the current repository in a separate buffer." 361 (interactive 362 (list (or (forge-current-repository) 363 (forge-get-repository 364 (forge-read-repository "Visit repository"))))) 365 (forge-visit repo)) 366 367 ;;; Create 368 369 (defun forge-create-pullreq (source target) 370 "Create a new pull-request for the current repository." 371 (interactive (forge-create-pullreq--read-args)) 372 (let* ((repo (forge-get-repository t)) 373 (buf (forge--prepare-post-buffer 374 "new-pullreq" 375 (forge--format repo "Create new pull-request on %p") 376 source target))) 377 (with-current-buffer buf 378 (setq forge--buffer-base-branch target) 379 (setq forge--buffer-head-branch source) 380 (setq forge--buffer-post-object repo) 381 (setq forge--submit-post-function 'forge--submit-create-pullreq)) 382 (forge--display-post-buffer buf))) 383 384 (defun forge-create-pullreq-from-issue (issue source target) 385 "Convert an existing ISSUE into a pull-request." 386 (interactive (cons (forge-read-issue "Convert issue") 387 (forge-create-pullreq--read-args))) 388 (setq issue (forge-get-issue issue)) 389 (forge--create-pullreq-from-issue (forge-get-repository issue) 390 issue source target)) 391 392 (defun forge-create-pullreq--read-args () 393 (let* ((source (magit-completing-read 394 "Source branch" 395 (magit-list-remote-branch-names) 396 nil t nil 'magit-revision-history 397 (or (when-let ((d (magit-branch-at-point))) 398 (if (magit-remote-branch-p d) 399 d 400 (magit-get-push-branch d t))) 401 (when-let ((d (magit-get-current-branch))) 402 (if (magit-remote-branch-p d) 403 d 404 (magit-get-push-branch d t)))))) 405 (repo (forge-get-repository t)) 406 (remote (oref repo remote)) 407 (targets (delete source (magit-list-remote-branch-names remote))) 408 (target (magit-completing-read 409 "Target branch" targets nil t nil 'magit-revision-history 410 (let* ((d (cdr (magit-split-branch-name source))) 411 (d (and (magit-branch-p d) d)) 412 (d (and d (magit-get-upstream-branch d))) 413 (d (and d (if (magit-remote-branch-p d) 414 d 415 (magit-get-upstream-branch d)))) 416 (d (or d (concat remote "/" 417 (or (oref repo default-branch) 418 "master"))))) 419 (car (member d targets)))))) 420 (list source target))) 421 422 (defun forge-create-issue () 423 "Create a new issue for the current repository." 424 (interactive) 425 (let* ((repo (forge-get-repository t)) 426 (buf (forge--prepare-post-buffer 427 "new-issue" 428 (forge--format repo "Create new issue on %p")))) 429 (when buf 430 (with-current-buffer buf 431 (setq forge--buffer-post-object repo) 432 (setq forge--submit-post-function 'forge--submit-create-issue)) 433 (forge--display-post-buffer buf)))) 434 435 (defun forge-create-post (&optional quote) 436 "Create a new post on an existing topic. 437 If the region is active, then quote that part of the post. 438 Otherwise and with a prefix argument quote the post that 439 point is currently on." 440 (interactive (list current-prefix-arg)) 441 (unless (derived-mode-p 'forge-topic-mode) 442 (user-error "This command is only available from topic buffers")) 443 (let* ((topic forge-buffer-topic) 444 (buf (forge--prepare-post-buffer 445 (forge--format topic "%i;new-comment") 446 (forge--format topic "New comment on #%i of %p"))) 447 (quote (cond 448 ((not (magit-section-match 'post)) nil) 449 ((use-region-p) 450 (buffer-substring-no-properties (region-beginning) 451 (region-end))) 452 (quote 453 (let ((section (magit-current-section))) 454 (string-trim-right 455 (buffer-substring-no-properties (oref section content) 456 (oref section end)))))))) 457 (with-current-buffer buf 458 (setq forge--buffer-post-object topic) 459 (setq forge--submit-post-function 'forge--submit-create-post) 460 (when quote 461 (goto-char (point-max)) 462 (unless (bobp) 463 (insert "\n")) 464 (insert (replace-regexp-in-string "^" "> " quote) "\n\n"))) 465 (forge--display-post-buffer buf))) 466 467 ;;; Edit 468 469 (defun forge-edit-post () 470 "Edit the current post." 471 (interactive) 472 (let* ((post (or (forge-post-at-point) 473 (user-error "There is no current post"))) 474 (buf (cl-typecase post 475 (forge-topic 476 (forge--prepare-post-buffer 477 (forge--format post "%i") 478 (forge--format post "Edit #%i of %p"))) 479 (forge-post 480 (forge--prepare-post-buffer 481 (forge--format post "%i;%I") 482 (forge--format post "Edit comment on #%i of %p")))))) 483 (with-current-buffer buf 484 (setq forge--buffer-post-object post) 485 (setq forge--submit-post-function 'forge--submit-edit-post) 486 (erase-buffer) 487 (when (cl-typep post 'forge-topic) 488 (insert "# " (oref post title) "\n\n")) 489 (insert (oref post body))) 490 (forge--display-post-buffer buf))) 491 492 (defun forge-edit-topic-title (topic) 493 "Edit the title of the current topic. 494 If there is no current topic or with a prefix argument read a 495 TOPIC and modify that instead." 496 (interactive (list (forge-read-topic "Edit title of"))) 497 (let ((topic (forge-get-topic topic))) 498 (forge--set-topic-title 499 (forge-get-repository topic) topic 500 (read-string "Title: " (oref topic title))))) 501 502 (defun forge-edit-topic-state (topic) 503 "Close or reopen the current topic. 504 If there is no current topic or with a prefix argument read a 505 TOPIC and modify that instead." 506 (interactive 507 (let* ((id (forge-read-topic "Close/reopen")) 508 (topic (forge-get-topic id))) 509 (if (magit-y-or-n-p 510 (format "%s %S" 511 (cl-ecase (oref topic state) 512 (merged (error "Merged pull-requests cannot be reopened")) 513 (closed "Reopen") 514 (open "Close")) 515 (car (forge--topic-format-choice topic)))) 516 (list id) 517 (user-error "Abort")))) 518 (let ((topic (forge-get-topic topic))) 519 (forge--set-topic-state (forge-get-repository topic) topic))) 520 521 (defun forge-edit-topic-milestone (topic) 522 (interactive (list (forge-read-topic "Edit milestone of"))) 523 (let* ((topic (forge-get-topic topic)) 524 (repo (forge-get-repository topic))) 525 (forge--set-topic-milestone 526 repo topic 527 (magit-completing-read 528 "Milestone" 529 (mapcar #'caddr (oref repo milestones)) 530 nil t (forge--get-topic-milestone topic))))) 531 532 (defun forge-edit-topic-labels (topic) 533 "Edit the labels of the current topic. 534 If there is no current topic or with a prefix argument read a 535 TOPIC and modify that instead." 536 (interactive (list (forge-read-topic "Edit labels of"))) 537 (let* ((topic (forge-get-topic topic)) 538 (repo (forge-get-repository topic)) 539 (crm-separator ",")) 540 (forge--set-topic-labels 541 repo topic (magit-completing-read-multiple* 542 "Labels: " 543 (mapcar #'cadr (oref repo labels)) 544 nil t 545 (mapconcat #'car (closql--iref topic 'labels) ","))))) 546 547 (defun forge-edit-topic-marks (topic marks) 548 "Edit the marks of the current topic. 549 If there is no current topic or with a prefix argument read a 550 TOPIC and modify that instead." 551 (interactive 552 (let ((topic (forge-read-topic "Edit marks of"))) 553 (list topic (forge-read-marks "Marks: " (forge-get-topic topic))))) 554 (oset (forge-get-topic topic) marks marks) 555 (magit-refresh)) 556 557 (defun forge-edit-topic-assignees (topic) 558 "Edit the assignees of the current topic. 559 If there is no current topic or with a prefix argument read a 560 TOPIC and modify that instead." 561 (interactive (list (forge-read-topic "Edit assignees of"))) 562 (let* ((topic (forge-get-topic topic)) 563 (repo (forge-get-repository topic)) 564 (value (closql--iref topic 'assignees)) 565 (choices (mapcar #'cadr (oref repo assignees))) 566 (crm-separator ",")) 567 (forge--set-topic-assignees 568 repo topic 569 (if (and (forge--childp topic 'forge-pullreq) 570 (forge--childp repo 'forge-gitlab-repository)) 571 (list ; Gitlab merge-requests can only be assigned to a single user. 572 (magit-completing-read 573 "Assignee" choices nil 574 nil ; Empty input removes assignee. 575 (car value))) 576 (magit-completing-read-multiple* 577 "Assignees: " choices nil 578 (if (forge--childp repo 'forge-gitlab-repository) 579 t ; Selecting something else would fail later on. 580 'confirm) 581 (mapconcat #'car value ",")))))) 582 583 (defun forge-edit-topic-review-requests (pullreq) 584 "Edit the review-requests of the current pull-request. 585 If there is no current topic or with a prefix argument read a 586 PULLREQ and modify that instead." 587 (interactive (list (forge-read-pullreq "Request review for"))) 588 (let* ((topic (forge-get-pullreq pullreq)) 589 (repo (forge-get-repository topic)) 590 (value (closql--iref topic 'review-requests)) 591 (choices (mapcar #'cadr (oref repo assignees))) 592 (crm-separator ",")) 593 (forge--set-topic-review-requests 594 repo topic 595 (magit-completing-read-multiple* 596 "Request review from: " choices nil 597 'confirm 598 (mapconcat #'car value ","))))) 599 600 (defun forge-edit-topic-note (topic) 601 "Edit your private note about the current topic. 602 If there is no current topic or with a prefix argument read a 603 TOPIC and modify that instead." 604 (interactive (list (forge-read-topic "Edit note about"))) 605 (let* ((topic (forge-get-topic topic)) 606 (buf (forge--prepare-post-buffer 607 (forge--format topic "%i;note") 608 (forge--format topic "New note on #%i of %p")))) 609 (with-current-buffer buf 610 (setq forge--buffer-post-object topic) 611 (setq forge--submit-post-function 'forge--save-note) 612 (erase-buffer) 613 (when-let ((note (oref topic note))) 614 (save-excursion (insert note ?\n)))) 615 (forge--display-post-buffer buf))) 616 617 ;;; Delete 618 619 (defun forge-delete-comment (comment) 620 "Delete the comment at point." 621 (interactive (list (or (forge-comment-at-point) 622 (user-error "There is no comment at point")))) 623 (when (yes-or-no-p "Do you really want to delete the selected comment? ") 624 (forge--delete-comment (forge-get-repository t) comment))) 625 626 ;;; Branch 627 628 ;;;###autoload 629 (defun forge-branch-pullreq (pullreq) 630 "Create and configure a new branch from a pull-request. 631 Please see the manual for more information." 632 (interactive (list (forge-read-pullreq "Branch pull request" t))) 633 (let ((pullreq (forge-get-pullreq pullreq))) 634 (if-let ((branch (forge--pullreq-branch-active pullreq))) 635 (progn (message "Branch %S already exists and is configured" branch) 636 branch) 637 (forge--branch-pullreq (forge-get-repository pullreq) pullreq)))) 638 639 (cl-defmethod forge--branch-pullreq ((_repo forge-unusedapi-repository) 640 (pullreq forge-pullreq)) 641 ;; We don't know enough to do a good job. 642 (let* ((number (oref pullreq number)) 643 (branch (format "pr-%s" number))) 644 (when (magit-branch-p branch) 645 (user-error "Branch `%s' already exists" branch)) 646 (magit-git "branch" branch (forge--pullreq-ref pullreq)) 647 ;; More often than not this is the correct target branch. 648 (magit-call-git "branch" branch "--set-upstream-to=master") 649 (magit-set (number-to-string number) "branch" branch "pullRequest") 650 (magit-refresh) 651 branch)) 652 653 (cl-defmethod forge--branch-pullreq ((repo forge-repository) 654 (pullreq forge-pullreq)) 655 (with-slots (number title editable-p cross-repo-p state 656 base-ref base-repo 657 head-ref head-repo head-user) 658 pullreq 659 (let* ((host (oref repo githost)) 660 (upstream (oref repo remote)) 661 (upstream-url (magit-git-string "remote" "get-url" upstream)) 662 (remote head-user) 663 (branch (forge--pullreq-branch-select pullreq)) 664 (pr-branch head-ref)) 665 (when (string-match-p ":" pr-branch) 666 ;; Such a branch name would be invalid. If we encounter 667 ;; it anyway, then that means that the source branch and 668 ;; the merge-request ref are missing. 669 (error "Cannot check out this Gitlab merge-request \ 670 because the source branch has been deleted")) 671 (if (not (eq state 'open)) 672 (magit-git "branch" "--force" branch 673 (format "refs/pullreqs/%s" number)) 674 (if (not cross-repo-p) 675 (let ((tracking (concat upstream "/" pr-branch))) 676 (unless (magit-branch-p tracking) 677 (magit-call-git "fetch" upstream)) 678 (magit-call-git "branch" branch tracking) 679 (magit-branch-maybe-adjust-upstream branch tracking) 680 (magit-set upstream "branch" branch "pushRemote") 681 (magit-set upstream "branch" branch "pullRequestRemote")) 682 (if (magit-remote-p remote) 683 (let ((url (magit-git-string "remote" "get-url" remote)) 684 (fetch (magit-get-all "remote" remote "fetch"))) 685 (unless (forge--url-equal 686 url (format "git@%s:%s.git" host head-repo)) 687 (user-error 688 "Remote `%s' already exists but does not point to %s" 689 remote url)) 690 (unless (or (member (format "+refs/heads/*:refs/remotes/%s/*" 691 remote) 692 fetch) 693 (member (format "+refs/heads/%s:refs/remotes/%s/%s" 694 pr-branch remote pr-branch) 695 fetch)) 696 (magit-git "remote" "set-branches" "--add" remote pr-branch) 697 (magit-git "fetch" remote))) 698 (magit-git 699 "remote" "add" "-f" "--no-tags" 700 "-t" pr-branch remote 701 (cond ((or (string-prefix-p "git@" upstream-url) 702 (string-prefix-p "ssh://git@" upstream-url)) 703 (format "git@%s:%s.git" host head-repo)) 704 ((string-prefix-p "https://" upstream-url) 705 (format "https://%s/%s.git" host head-repo)) 706 ((string-prefix-p "git://" upstream-url) 707 (format "git://%s/%s.git" host head-repo)) 708 ((string-prefix-p "http://" upstream-url) 709 (format "http://%s/%s.git" host head-repo)) 710 (t (error "%s has an unexpected format" upstream-url))))) 711 (magit-git "branch" "--force" branch (concat remote "/" pr-branch)) 712 (if (and editable-p 713 (equal branch pr-branch)) 714 (magit-set remote "branch" branch "pushRemote") 715 (magit-set upstream "branch" branch "pushRemote"))) 716 (magit-set remote "branch" branch "pullRequestRemote") 717 (magit-set "true" "branch" branch "rebase") 718 (magit-git "branch" branch 719 (concat "--set-upstream-to=" 720 (if (or magit-branch-prefer-remote-upstream 721 (not (magit-branch-p base-ref))) 722 (concat upstream "/" base-ref) 723 base-ref)))) 724 (magit-set (number-to-string number) "branch" branch "pullRequest") 725 (magit-set title "branch" branch "description") 726 (magit-refresh) 727 branch))) 728 729 ;;;###autoload 730 (defun forge-checkout-pullreq (pullreq) 731 "Create, configure and checkout a new branch from a pull-request. 732 Please see the manual for more information." 733 (interactive (list (forge-read-pullreq "Checkout pull request" t))) 734 (let ((pullreq (forge-get-pullreq pullreq))) 735 (magit-checkout 736 (or (if (not (eq (oref pullreq state) 'open)) 737 (magit-ref-p (format "refs/pullreqs/%s" 738 (oref pullreq number))) 739 (forge--pullreq-branch-active pullreq)) 740 (let ((magit-inhibit-refresh t)) 741 (forge-branch-pullreq pullreq)))))) 742 743 ;;;###autoload 744 (defun forge-checkout-worktree (path pullreq) 745 "Create, configure and checkout a new worktree from a pull-request. 746 This is like `forge-checkout-pullreq', except that it also 747 creates a new worktree. Please see the manual for more 748 information." 749 (interactive 750 (let ((id (forge-read-pullreq "Checkout pull request" t))) 751 (list (funcall forge-checkout-worktree-read-directory-function 752 (forge-get-pullreq id)) 753 id))) 754 (when (and (file-exists-p path) 755 (not (and (file-directory-p path) 756 (= (length (directory-files "/tmp/testing/")) 2)))) 757 (user-error "%s already exists and isn't empty" path)) 758 (magit-worktree-checkout path 759 (let ((magit-inhibit-refresh t)) 760 (forge-branch-pullreq 761 (forge-get-pullreq pullreq))))) 762 763 (defun forge-checkout-worktree-default-read-directory-function (pullreq) 764 (with-slots (number head-ref) pullreq 765 (let ((path (read-directory-name 766 (format "Checkout #%s in new worktree: " number) 767 (file-name-directory 768 (directory-file-name default-directory)) 769 nil nil 770 (let ((branch (forge--pullreq-branch-internal pullreq))) 771 (if (string-match-p "\\`pr-[0-9]+\\'" branch) 772 (number-to-string number) 773 (format "%s-%s" number 774 (replace-regexp-in-string "/" "-" head-ref))))))) 775 (when (equal path "") 776 (user-error "The empty string isn't a valid path")) 777 path))) 778 779 ;;; Marks 780 781 (defun forge-create-mark (name face description) 782 "Define a new mark that topics can be marked with." 783 (interactive 784 (list (read-string "Name: ") 785 (magit-read-char-case "Set appearance using " nil 786 (?n "a face [n]ame" 787 (read-face-name "Face name: ")) 788 (?s "face [s]exp" 789 (read-from-minibuffer 790 "Face sexp: " 791 "(:background \"\" :foreground \"\" :box t)" 792 read-expression-map t))) 793 (let ((str (read-string "Description: "))) 794 (and (not (equal str "")) str)))) 795 (forge-sql [:insert-into mark :values $v1] 796 (vector nil (forge--uuid) name face description))) 797 798 (defun forge-edit-mark (id name face description) 799 "Define a new mark that topics can be marked with." 800 (interactive 801 (pcase-let ((`(,id ,name ,face ,description) 802 (forge-read-mark "Edit mark"))) 803 (list id 804 (read-string "Name: " name) 805 (magit-read-char-case "Set appearance using " nil 806 (?n "a face [n]ame" 807 (read-face-name "Face name: " (and (symbolp face) face))) 808 (?s "face [s]exp" 809 (read-from-minibuffer 810 "Face sexp: " 811 (if (listp face) 812 (format "%S" face) 813 "(:background \"\" :foreground \"\" :box t)") 814 read-expression-map t))) 815 (let ((str (read-string "Description: " nil nil description))) 816 (and (not (equal str "")) str))))) 817 (forge-sql [:update mark 818 :set (= [name face description] $v1) 819 :where (= id $s2)] 820 (vector name face description) id)) 821 822 (defun forge-read-mark (prompt) 823 "Read a topic. Return (ID NAME FACE DESCRIPTION)." 824 (let* ((marks (forge-sql [:select [id name face description] :from mark])) 825 (name (completing-read prompt (mapcar #'cadr marks) nil t))) 826 (--first (equal (cadr it) name) marks))) 827 828 (defun forge-read-marks (prompt &optional topic) 829 "Read multiple mark names and return the respective ids." 830 (let ((marks (forge-sql [:select [name id] :from mark])) 831 (crm-separator ",")) 832 (--map (cadr (assoc it marks)) 833 (magit-completing-read-multiple* 834 prompt (mapcar #'car marks) nil t 835 (and topic 836 (mapconcat #'car (closql--iref topic 'marks) ",")))))) 837 838 (defun forge-toggle-mark (mark) 839 "Toggle MARK for the current topic." 840 (if-let ((topic (forge-current-topic))) 841 (let* ((value (mapcar #'car (closql--iref topic 'marks))) 842 (value (if (member mark value) 843 (delete mark value) 844 (cons mark value))) 845 (marks (forge-sql [:select [name id] :from mark]))) 846 (oset topic marks (--map (cadr (assoc it marks)) value)) 847 (magit-refresh)) 848 (user-error "There is no topic at point"))) 849 850 ;;; Fork 851 852 ;;;###autoload 853 (defun forge-fork (fork remote) 854 "Fork the current repository to FORK and add it as a REMOTE. 855 If the fork already exists, then that isn't an error; the remote 856 is added anyway. Currently this only supports Github and Gitlab." 857 (interactive 858 (let ((fork (magit-completing-read "Fork to" 859 (mapcar #'car forge-owned-accounts)))) 860 (list fork 861 (read-string "Remote name: " 862 (or (plist-get (cdr (assoc fork forge-owned-accounts)) 863 'remote-name) 864 fork))))) 865 (let ((repo (forge-get-repository 'stub))) 866 (forge--fork-repository repo fork) 867 (magit-remote-add remote 868 (magit-clone--format-url (oref repo githost) fork 869 (oref repo name)) 870 (list "--fetch")))) 871 872 ;;; Misc 873 874 (transient-define-infix forge-forge.remote () 875 "Change the local value of the `forge.remote' Git variable." 876 :class 'magit--git-variable:choices 877 :variable "forge.remote" 878 :choices 'magit-list-remotes 879 :default "origin") 880 881 ;;;###autoload 882 (defun forge-list-notifications () 883 "List notifications." 884 (interactive) 885 (forge-notifications-setup-buffer)) 886 887 (transient-define-suffix forge-toggle-display-in-status-buffer () 888 "Toggle whether to display topics in the current status buffer." 889 :description (lambda () 890 (if forge-display-in-status-buffer 891 "hide all topics" 892 "display topics")) 893 (interactive) 894 (setq forge-display-in-status-buffer (not forge-display-in-status-buffer)) 895 (magit-refresh)) 896 897 (transient-define-suffix forge-toggle-closed-visibility () 898 "Toggle whether to display recently closed topics. 899 This only affect the current status buffer." 900 :description (lambda () 901 (if (or (atom forge-topic-list-limit) 902 (> (cdr forge-topic-list-limit) 0)) 903 "hide closed topics" 904 "display recently closed topics")) 905 :inapt-if-not (lambda () forge-display-in-status-buffer) 906 (interactive) 907 (magit-repository-local-delete (list 'forge-ls-recent-topics 'issue)) 908 (magit-repository-local-delete (list 'forge-ls-recent-topics 'pullreq)) 909 (make-local-variable 'forge-topic-list-limit) 910 (if (atom forge-topic-list-limit) 911 (setq forge-topic-list-limit (cons forge-topic-list-limit 5)) 912 (setcdr forge-topic-list-limit (* -1 (cdr forge-topic-list-limit)))) 913 (magit-refresh)) 914 915 ;;;###autoload 916 (defun forge-add-pullreq-refspec () 917 "Configure Git to fetch all pull-requests. 918 This is done by adding \"+refs/pull/*/head:refs/pullreqs/*\" 919 to the value of `remote.REMOTE.fetch', where REMOTE is the 920 upstream remote. Also fetch from REMOTE." 921 (interactive) 922 (let* ((repo (forge-get-repository 'stub)) 923 (remote (oref repo remote)) 924 (fetch (magit-get-all "remote" remote "fetch")) 925 (refspec (oref repo pullreq-refspec))) 926 (if (member refspec fetch) 927 (message "Pull-request refspec is already active") 928 (magit-call-git "config" "--add" 929 (format "remote.%s.fetch" remote) 930 refspec) 931 (magit-git-fetch remote (magit-fetch-arguments))))) 932 933 ;;;###autoload 934 (defun forge-add-repository (url) 935 "Add a repository to the database. 936 Offer to either pull topics (now and in the future) or to only 937 pull individual topics when the user invokes `forge-pull-topic'." 938 (declare (interactive-only t)) 939 (interactive 940 (let ((str (magit-read-string-ns 941 "Add repository to database (url or name)" 942 (when-let ((repo (forge-get-repository 'stub)) 943 (remote (oref repo remote))) 944 (magit-git-string "remote" "get-url" remote))))) 945 (if (string-match-p "\\(://\\|@\\)" str) 946 (list str) 947 (list (magit-clone--name-to-url str))))) 948 (if (forge-get-repository url nil 'full) 949 (user-error "%s is already tracked in Forge database" url) 950 (let ((repo (forge-get-repository url nil 'create))) 951 (oset repo sparse-p nil) 952 (magit-read-char-case "Pull " nil 953 (?a "[a]ll topics" 954 (forge-pull repo)) 955 (?i "[i]ndividual topics (useful for casual contributors)" 956 (oset repo selective-p t) 957 (forge--pull repo nil)))))) 958 959 ;;;###autoload 960 (defun forge-add-user-repositories (host user) 961 "Add all of USER's repositories from HOST to the database. 962 This may take a while. Only Github is supported at the moment." 963 (interactive 964 (list (forge-read-host "Add repositories from Github host" 965 'forge-github-repository) 966 (read-string "User: "))) 967 (forge--add-user-repos 'forge-github-repository host user)) 968 969 ;;;###autoload 970 (defun forge-add-organization-repositories (host organization) 971 "Add all of ORGANIZATION's repositories from HOST to the database. 972 This may take a while. Only Github is supported at the moment." 973 (interactive 974 (list (forge-read-host "Add repositories from Github host" 975 'forge-github-repository) 976 (read-string "Organization: "))) 977 (forge--add-organization-repos 'forge-github-repository host organization)) 978 979 ;;;###autoload 980 (defun forge-merge (pullreq method) 981 "Merge the current pull-request using METHOD using the forge's API. 982 983 If there is no current pull-request or with a prefix argument, 984 then read pull-request PULLREQ to visit instead. 985 986 Use of this command is discouraged. Unless the remote repository 987 is configured to disallow that, you should instead merge locally 988 and then push the target branch. Forges detect that you have 989 done that and respond by automatically marking the pull-request 990 as merged." 991 (interactive 992 (list (forge-read-pullreq "Merge pull-request" t) 993 (if (forge--childp (forge-get-repository t) 'forge-gitlab-repository) 994 (magit-read-char-case "Merge method " t 995 (?m "[m]erge" 'merge) 996 (?s "[s]quash" 'squash)) 997 (magit-read-char-case "Merge method " t 998 (?m "[m]erge" 'merge) 999 (?s "[s]quash" 'squash) 1000 (?r "[r]ebase" 'rebase))))) 1001 (let ((pullreq (forge-get-pullreq pullreq))) 1002 (forge--merge-pullreq (forge-get-repository pullreq) 1003 pullreq 1004 (magit-rev-hash 1005 (forge--pullreq-branch-internal pullreq)) 1006 method)) 1007 (forge-pull)) 1008 1009 ;;;###autoload 1010 (defun forge-remove-repository (host owner name) 1011 "Remove a repository from the database." 1012 (interactive 1013 (pcase-let ((`(,githost ,owner ,name) 1014 (forge-read-repository "Remove repository from db"))) 1015 (if (yes-or-no-p 1016 (format "Do you really want to remove \"%s/%s @%s\" from the db? " 1017 owner name githost)) 1018 (list githost owner name) 1019 (user-error "Abort")))) 1020 (closql-delete (forge-get-repository (list host owner name))) 1021 (magit-refresh)) 1022 1023 ;;;###autoload 1024 (defun forge-remove-topic-locally (topic) 1025 "Remove a topic from the local database only. 1026 Due to how the supported APIs work, it would be too expensive to 1027 automatically remove topics from the local datbase that were 1028 removed from the forge. The purpose of this command is to allow 1029 you to manually clean up the local database." 1030 (interactive (list (forge-read-topic "Delete topic LOCALLY only"))) 1031 (setq topic (forge-get-topic topic)) 1032 (closql-delete topic) 1033 (if (and (derived-mode-p 'forge-topic-mode) 1034 (eq (oref topic id) 1035 (oref forge-buffer-topic id))) 1036 (kill-buffer (current-buffer)) 1037 (magit-refresh))) 1038 1039 ;;;###autoload 1040 (defun forge-reset-database () 1041 "Move the current database file to the trash. 1042 This is useful after the database scheme has changed, which will 1043 happen a few times while the forge functionality is still under 1044 heavy development." 1045 (interactive) 1046 (when (and (file-exists-p forge-database-file) 1047 (yes-or-no-p "Really trash Forge's database file? ")) 1048 (when forge--db-connection 1049 (emacsql-close forge--db-connection)) 1050 (delete-file forge-database-file t) 1051 (magit-refresh))) 1052 1053 (defun forge-enable-sql-logging () 1054 "Enable logging Forge's SQL queries." 1055 (interactive) 1056 (let ((db (forge-db))) 1057 (emacsql-enable-debugging db) 1058 (switch-to-buffer-other-window (emacsql-log-buffer db)))) 1059 1060 (magit-define-section-jumper forge-jump-to-pullreqs "Pull requests" pullreqs) 1061 (magit-define-section-jumper forge-jump-to-issues "Issues" issues) 1062 1063 ;;; _ 1064 (provide 'forge-commands) 1065 ;;; forge-commands.el ends here